From 642c3cfbb2e1414a486f663319daaa3a199d7850 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 7 Feb 2022 20:59:53 -0800 Subject: [PATCH 001/233] fix alpine dependencies --- util/install.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/util/install.sh b/util/install.sh index 259c2645f..936530f7c 100755 --- a/util/install.sh +++ b/util/install.sh @@ -318,7 +318,7 @@ install_dependencies() { elif has_cmd yum ; then yum_install build-essential $deps elif has_cmd apk ; then - deps="gcc make tar curl cmake" + deps="gcc make tar curl cmake ninja" apk_install $deps elif has_cmd pacman; then deps="gcc make tar curl cmake ninja pkg-config" # ninja-build -> ninja From d92bce4f7bacb759806ea47d007bc0c5fd6b7c8a Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 7 Feb 2022 21:00:22 -0800 Subject: [PATCH 002/233] add midpoint and lerp --- kklib/include/kklib/bits.h | 47 ++++++++++++++++++++++++++++++++++++++ lib/std/num/float64.kk | 26 +++++++++++++++++++++ 2 files changed, 73 insertions(+) diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index fd3dff4fc..a665b1c24 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -519,4 +519,51 @@ static inline uint8_t kk_bits_digits(kk_uintx_t x) { } +/* --------------------------------------------------------------- + midpoint(x,y): the average of x and y, rounded towards x. + note: written to avoid overflow and UB. See also + +------------------------------------------------------------------ */ + +static inline int32_t kk_bits_midpoint32( int32_t x, int32_t y ) { + if (x <= y) { + const int32_t diff = ((uint32_t)y - (uint32_t)x)/2; + return x + diff; + } + else { + const int32_t diff = -(((uint32_t)x - (uint32_t)y)/2); + return x + diff; + } +} + +static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { + if (x <= y) return (x + (y-x)/2); + else return (x - (x-y)/2); +} + +static inline int64_t kk_bits_midpoint64( int64_t x, int64_t y ) { + if (x <= y) { + const int64_t diff = ((uint64_t)y - (uint64_t)x)/2; + return x + diff; + } + else { + const int64_t diff = -(((uint64_t)x - (uint64_t)y)/2); + return x + diff; + } +} + +static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { + if (x <= y) return (x + (y-x)/2); + else return (x - (x-y)/2); +} + +static inline kk_intx_t kk_bits_midpoint( kk_intx_t x, kk_intx_t y ) { + return kk_bitsx(midpoint)(x,y); +} + +static inline kk_uintx_t kk_bits_umidpoint( kk_uintx_t x, kk_uintx_t y ) { + return kk_bitsx(umidpoint)(x,y); +} + + #endif // include guard diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 223de40fb..2dbe98c7d 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -470,6 +470,32 @@ pub fun compare( x : float64, y : float64 ) : order compare(ix,iy) +// The midpoint is the average of `x` and `y`. +// Avoids overflow on large numbers. +pub fun midpoint( x : float64, y : float64 ) : float64 + if is-subnormal(x) || is-subnormal(y) + then (x + y) / 2.0 + else (x / 2.0) + (y / 2.0) + + +// Linear interpolation, calculating `x + t*(y - x)` but avoids troublesome edge cases. +// Follows the C++20 [specification](http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2019/p0811r3.html). +// In particular, if `x.is-finite && y.is-finite`, then: +// - exact: `lerp(x,y,0.0) == x` and `lerp(x,y,1.0) == y` +// - monotonic: if `x <= y` and `t1 <= t2`, then `compare( lerp(x,y,t1), lerp(x,y,t2) ) <= Eq` (and other cases) +// - deterministic: Only `lerp(x,x,flt-inf)` results in `nan` +// - bounded: `t<0.0 || t>1.0 || is-finite(lerp(x,y,t))` +// - consistent: `lerp(x,x,t) == x` +pub fun lerp( x : float64, y : float64, t : float64 ) : float64 + if (x <= 0.0 && y >= 0.0) || (x >= 0.0 && y <= 0.0) then + t*y + (1.0 - t)*x + elif t == 1.0 then + y + else + val z = x + t*(y - x) + if ((t > 1.0) == (y > x)) then max(y,z) else min(y,z) + + //----------------------------------------- // Show in hexadecimal //----------------------------------------- From 193d9e714e9fa5237c696f4c0a2a8180693ff770 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 10 Feb 2022 16:10:59 -0800 Subject: [PATCH 003/233] bump version to 2.4.1 for further development --- koka.cabal | 4 ++-- package.yaml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/koka.cabal b/koka.cabal index 8ff5dc5b0..aff24b1ad 100644 --- a/koka.cabal +++ b/koka.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: koka -version: 2.4.0 +version: 2.4.1 description: Please see the README on GitHub at homepage: https://github.com/koka-lang/koka#readme bug-reports: https://github.com/koka-lang/koka/issues @@ -129,7 +129,7 @@ executable koka CPP OverloadedStrings ghc-options: -rtsopts -j8 - cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.0" -DREADLINE=0 + cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.1" -DREADLINE=0 include-dirs: src/Platform/cpp/Platform c-sources: diff --git a/package.yaml b/package.yaml index b236e52f2..886039468 100644 --- a/package.yaml +++ b/package.yaml @@ -6,7 +6,7 @@ # - util/minbuild name: koka -version: 2.4.0 +version: 2.4.1 github: "koka-lang/koka" license: Apache-2.0 author: Daan Leijen @@ -53,7 +53,7 @@ executables: cpp-options: - -DKOKA_MAIN="koka" - -DKOKA_VARIANT="release" - - -DKOKA_VERSION="2.4.0" + - -DKOKA_VERSION="2.4.1" - -DREADLINE=0 # 1:getline, 2:readline, 3:haskeline, or 0:isocline when: - condition: os(windows) From 8b83491cac2f1cac64ae813e423cdc9211f5b4fa Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 10 Feb 2022 16:11:09 -0800 Subject: [PATCH 004/233] add midpoint functions --- kklib/include/kklib/bits.h | 38 ++++++++++++----------------------- kklib/include/kklib/integer.h | 2 ++ lib/std/num/float64.kk | 2 +- 3 files changed, 16 insertions(+), 26 deletions(-) diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index a665b1c24..54851db13 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -526,39 +526,27 @@ static inline uint8_t kk_bits_digits(kk_uintx_t x) { ------------------------------------------------------------------ */ static inline int32_t kk_bits_midpoint32( int32_t x, int32_t y ) { - if (x <= y) { - const int32_t diff = ((uint32_t)y - (uint32_t)x)/2; - return x + diff; - } - else { - const int32_t diff = -(((uint32_t)x - (uint32_t)y)/2); - return x + diff; - } + if (kk_likely(x <= y)) return x + (int32_t)(((uint32_t)y - (uint32_t)x)/2); + else return x - (int32_t)(((uint32_t)x - (uint32_t)y)/2); } -static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { - if (x <= y) return (x + (y-x)/2); - else return (x - (x-y)/2); +static inline int64_t kk_bits_midpoint64(int64_t x, int64_t y) { + if (kk_likely(x <= y)) return x + (int64_t)(((uint64_t)y - (uint64_t)x)/2); + else return x - (int64_t)(((uint64_t)x - (uint64_t)y)/2); } -static inline int64_t kk_bits_midpoint64( int64_t x, int64_t y ) { - if (x <= y) { - const int64_t diff = ((uint64_t)y - (uint64_t)x)/2; - return x + diff; - } - else { - const int64_t diff = -(((uint64_t)x - (uint64_t)y)/2); - return x + diff; - } +static inline kk_intx_t kk_bits_midpoint(kk_intx_t x, kk_intx_t y) { + return kk_bitsx(midpoint)(x, y); } -static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { - if (x <= y) return (x + (y-x)/2); - else return (x - (x-y)/2); +static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { + if (kk_likely(x <= y)) return (x + (y-x)/2); + else return (x - (x-y)/2); } -static inline kk_intx_t kk_bits_midpoint( kk_intx_t x, kk_intx_t y ) { - return kk_bitsx(midpoint)(x,y); +static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { + if (kk_likely(x <= y)) return (x + (y-x)/2); + else return (x - (x-y)/2); } static inline kk_uintx_t kk_bits_umidpoint( kk_uintx_t x, kk_uintx_t y ) { diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 93f5dd412..866634372 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -318,6 +318,7 @@ kk_decl_export double kk_double_round_even(double d, kk_context_t* ctx); static inline kk_integer_t kk_integer_from_uint8(uint8_t u, kk_context_t* ctx) { #if (KK_SMALLINT_MAX >= UINT8_MAX) + kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); @@ -353,6 +354,7 @@ static inline kk_integer_t kk_integer_from_int32(int32_t i, kk_context_t* ctx) { static inline kk_integer_t kk_integer_from_uint32(uint32_t u, kk_context_t* ctx) { #if (KK_SMALLINT_MAX >= UINT32_MAX) + kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 2dbe98c7d..a326e6c6d 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -483,7 +483,7 @@ pub fun midpoint( x : float64, y : float64 ) : float64 // In particular, if `x.is-finite && y.is-finite`, then: // - exact: `lerp(x,y,0.0) == x` and `lerp(x,y,1.0) == y` // - monotonic: if `x <= y` and `t1 <= t2`, then `compare( lerp(x,y,t1), lerp(x,y,t2) ) <= Eq` (and other cases) -// - deterministic: Only `lerp(x,x,flt-inf)` results in `nan` +// - deterministic: only `lerp(x,x,flt-inf)` results in `nan` // - bounded: `t<0.0 || t>1.0 || is-finite(lerp(x,y,t))` // - consistent: `lerp(x,x,t) == x` pub fun lerp( x : float64, y : float64, t : float64 ) : float64 From a064cff1d3fe37c04114420dbe376b92d1acc217 Mon Sep 17 00:00:00 2001 From: Daan Date: Wed, 16 Feb 2022 16:40:02 -0800 Subject: [PATCH 005/233] remove simplify from type inference to avoid simplifying direct recursive calls (see type/hm3.kk) --- src/Core/Simplify.hs | 2 +- src/Core/Specialize.hs | 3 ++- src/Type/Infer.hs | 8 ++++---- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index 958e1f772..61c16d9bf 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -436,7 +436,7 @@ bottomUp (App (Var v _) [App (Var w _) [arg]]) | (getName v == nameUnbox && get -- direct application of arguments to a lambda: fun(x1...xn) { f(x1,...,xn) } -> f -bottomUp (Lam pars eff (App f@(Var _ info) args)) | notExternal && length pars == length args && argsMatchPars +bottomUp (Lam pars eff (App f@(Var _ info) args)) | notExternal && length pars == length args && argsMatchPars = f where argsMatchPars = and (zipWith argMatchPar pars args) diff --git a/src/Core/Specialize.hs b/src/Core/Specialize.hs index 1bdd419e5..4ce400eb3 100644 --- a/src/Core/Specialize.hs +++ b/src/Core/Specialize.hs @@ -438,7 +438,8 @@ recursiveCalls Def{ defName=thisDefName, defExpr=expr } -> go body TypeLam types (Lam params eff body) -> go body - _ -> failure "recursiveCalls: not a function" + -- _ -> (Nothing,[]) + _ -> failure ("Core.Specialize: recursiveCalls: not a function: " ++ show thisDefName ++ ": " ++ show expr) where go body = let (types, args) = unzip $ foldMapExpr f body diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index 8f8081b06..145df746f 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -69,7 +69,7 @@ import Core.AnalysisMatch( analyzeBranches ) -- import Core.AnalysisResume( analyzeResume ) import Core.Divergent( analyzeDivergence ) import Core.BindingGroups( regroup ) -import Core.Simplify( uniqueSimplify ) +-- import Core.Simplify( uniqueSimplify ) import qualified Syntax.RangeMap as RM @@ -343,7 +343,7 @@ inferRecDef2 topLevel coreDef divergent (def,mbAssumed) -> -- fix it up by adding the polymorphic type application do assumedTpX <- subst assumedTp >>= normalize True -- resTp0 -- resTpX <- subst resTp0 >>= normalize - simexpr <- liftUnique $ uniqueSimplify penv False False 1 {-runs-} 0 expr + simexpr <- return expr -- liftUnique $ uniqueSimplify penv False False 1 {-runs-} 0 expr coreX <- subst simexpr let -- coreX = simplify expr -- coref0 (Core.defExpr coreDef) mvars = [TypeVar id kind Bound | TypeVar id kind _ <- tvars] @@ -366,13 +366,13 @@ inferRecDef2 topLevel coreDef divergent (def,mbAssumed) -} (Just (_,_), _) | divergent -- we added a divergent effect, fix up the occurrences of the assumed type -> do assumedTpX <- normalize True assumedTp >>= subst -- resTp0 - simResCore1 <- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 + simResCore1 <- return resCore1 -- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 coreX <- subst simResCore1 let resCoreX = (CoreVar.|~>) [(Core.TName ({- unqualify -} name) assumedTpX, Core.Var (Core.TName ({- unqualify -} name) resTp1) info)] coreX return (resTp1, resCoreX) (Just _,_) -- ensure we insert the right info (test: static/div2-ack) -> do assumedTpX <- normalize True assumedTp >>= subst - simResCore1 <- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 + simResCore1 <- return resCore1 -- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 coreX <- subst simResCore1 let resCoreX = (CoreVar.|~>) [(Core.TName ({- unqualify -} name) assumedTpX, Core.Var (Core.TName ({- unqualify -} name) resTp1) info)] coreX return (resTp1, resCoreX) From 4304d63654a7609168277e8b4795e7b3809e4200 Mon Sep 17 00:00:00 2001 From: Daan Date: Wed, 16 Feb 2022 16:41:18 -0800 Subject: [PATCH 006/233] add test case for direct recursion --- test/type/hm3.kk | 6 ++++++ test/type/hm3.kk.out | 2 ++ 2 files changed, 8 insertions(+) create mode 100644 test/type/hm3.kk create mode 100644 test/type/hm3.kk.out diff --git a/test/type/hm3.kk b/test/type/hm3.kk new file mode 100644 index 000000000..9c0a4199f --- /dev/null +++ b/test/type/hm3.kk @@ -0,0 +1,6 @@ +fun f(y) + val h = fn(x) f(x) + h(y) + +fun g(x) + g(x) \ No newline at end of file diff --git a/test/type/hm3.kk.out b/test/type/hm3.kk.out new file mode 100644 index 000000000..3ef31cd20 --- /dev/null +++ b/test/type/hm3.kk.out @@ -0,0 +1,2 @@ +type/hm3/f: forall (a) -> div b +type/hm3/g: forall (a) -> div b \ No newline at end of file From f7cd376948f1b633c909c82315143f5539db4261 Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 17 Feb 2022 22:33:42 -0800 Subject: [PATCH 007/233] better specification of raw string literals --- doc/spec/book.kk.md | 2 ++ doc/spec/spec.kk.md | 61 +++++++++++++++++++--------------------- doc/spec/styles/book.css | 5 +++- 3 files changed, 35 insertions(+), 33 deletions(-) diff --git a/doc/spec/book.kk.md b/doc/spec/book.kk.md index c84461c3f..bbbf41971 100644 --- a/doc/spec/book.kk.md +++ b/doc/spec/book.kk.md @@ -27,6 +27,8 @@ body { ~bar : before='|' ~many : before='{ ' after=' }' +~manyn : before='{ ' after=' }~_n_~' +~manyx : before='{ ' after=' }' ~opt : before='[ ' after=' ]' diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 9624304c3..5a20f77f6 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -26,9 +26,10 @@ In the patterns, we use the following notations: | ( _pattern_ ) | | Grouping | | [ _pattern_ ] | | Optional occurrence of _pattern_ | | { _pattern_ } | | Zero or more occurrences of _pattern_ | +| { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | | _pattern_~1~ []{.bar} _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | |   | | | -| _pattern_~<!_diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | +| _pattern_~<! _diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | | _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | {.grammar} @@ -102,7 +103,7 @@ grammar will draw it's lexemes from the _lex_ production. | _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | |   | | | | | _conid_ | ::= | _upperid_ | | -| _varid_ | ::= | _lowerid_~<!_reserved_>~ | | +| _varid_ | ::= | _lowerid_~<! _reserved_>~ | | |   | | | | | _lowerid_ | ::= | _lower_ _idtail_ | | | _upperid_ | ::= | _upper_ _idtail_ | | @@ -193,17 +194,14 @@ std/core/(&) ### Literals |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` ( _graphic_~<``'``[]{.bar}``\``>~ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _escape_ ) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_~<``"``[]{.bar}``\``>~ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _escape_]{.many} ``"`` | | -| | &bar; | ``r`` _rawstring_ | | -| _rawstring_ | ::= | ``#`` _rawstring_ ``#`` | | -| | &bar; | ``"`` [_graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_]{.many} ``"`` | (non-greedy match) | +| _char_ | ::= | ``'`` (_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | +| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | +| _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | |   | | | | | _escape_ | ::= | ``\`` ( _charesc_ []{.bar} _hexesc_ ) | | | _charesc_ | ::= | `n` []{.bar} `r` []{.bar} `t` []{.bar} ``\`` []{.bar} ``"`` []{.bar} ``'`` | | -| _hexesc_ | ::= | `x` _hexdigit_~2~ []{.bar} `u` _hexdigit_~4~ []{.bar} ``U`` _hexdigit_~4~ _hexdigit_~2~ | | -| _hexdigit_~4~ | ::= | _hexdigit_ _hexdigit_ _hexdigit_ _hexdigit_ | | -| _hexdigit_~2~ | ::= | _hexdigit_ _hexdigit_ | | +| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ []{.bar} `u` [_hexdigit_]{.manyx}~4~ []{.bar} ``U`` [_hexdigit_]{.manyx}~6~ | | |   | | | | | _float_ | ::= | [``-``]{.opt} (decfloat []{.bar} hexfloat) | | | _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} []{.bar} _decexp_) | | @@ -232,38 +230,37 @@ std/core/(&) | _linechar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | _blockchars_~<_blockchars_\ (/*[]{.bar}*/)\ _blockchars_>~ | | -| _blockchars_ | ::= | [_blockchar_]{.many} | | -| _blockchar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | | +| _blockpart_ | ::= | [_any_]{.many}~/*[]{.bar}*/)\ [_any_]{.many}>~ | | {.grammar .lex} ### Character classes |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| | _letter_ | ::= | _upper_ []{.bar} _lower_ | | -| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | -| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | -| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | -| _posdigit_ | ::= | ``1..9`` | | -| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | +| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | +| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | +| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | +| _posdigit_ | ::= | ``1..9`` | | +| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | |   | | | | | _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | |   | | | | -| _space_ | ::= | ``x20`` | (a space) | -| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | -| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | -| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | -| _graphic_ | ::= | ``x21``..``x7E`` | (a visible character) | +| _space_ | ::= | ``x20`` | (a space) | +| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | +| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | +| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | +| _graphic_ | ::= | ``x21``..``x7E`` | (a visible character) | +| _any_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | (in comments and raw strings) | |   | | | | -| _utf8_ | ::= | (``xC2``..``xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0``..``xBF``) _cont_ | | -| | &bar; | (``xE1``..``xEC``) _cont_ _cont_ | | -| | &bar; | ``xED`` (``x80``..``x9F``) _cont_ | | -| | &bar; | (``xEE``..``xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90``..``xBF``) _cont_ _cont_ | | -| | &bar; | (``xF1``..``xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80``..``x8F``) _cont_ _cont_ | | -| _cont_ | ::= | ``x80``..``xBF`` | | +| _utf8_ | ::= | (``xC2``..``xDF``) _cont_ | | +| | &bar; | ``xE0`` (``xA0``..``xBF``) _cont_ | | +| | &bar; | (``xE1``..``xEC``) _cont_ _cont_ | | +| | &bar; | ``xED`` (``x80``..``x9F``) _cont_ | | +| | &bar; | (``xEE``..``xEF``) _cont_ _cont_ | | +| | &bar; | ``xF0`` (``x90``..``xBF``) _cont_ _cont_| | +| | &bar; | (``xF1``..``xF3``) _cont_ _cont_ _cont_ | | +| | &bar; | ``xF4`` (``x80``..``x8F``) _cont_ _cont_| | +| _cont_ | ::= | ``x80``..``xBF`` | | {.grammar .lex} diff --git a/doc/spec/styles/book.css b/doc/spec/styles/book.css index c304a4569..d5a50afa9 100644 --- a/doc/spec/styles/book.css +++ b/doc/spec/styles/book.css @@ -112,10 +112,13 @@ table .kw, table .tp, table .co, font-style: italic; } -.opt, .many { +.opt, .many, .manyn { padding: 0ex 0.5ex; } +.manyx { + padding-left: 0.5ex; +} #toc { display: none; From c6f1bf9fbdecdcb293de98cf0cb39632e24aa65b Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 17 Feb 2022 23:54:45 -0800 Subject: [PATCH 008/233] disallow unsafe bidi characters in comments etc --- doc/spec/grammar/lexer.l | 2813 +++++++++++++++++++------------------- doc/spec/spec.kk.md | 1573 ++++++++++----------- src/Syntax/Lexer.x | 26 +- 3 files changed, 2221 insertions(+), 2191 deletions(-) diff --git a/doc/spec/grammar/lexer.l b/doc/spec/grammar/lexer.l index 2f47b3bd8..9b2f80130 100644 --- a/doc/spec/grammar/lexer.l +++ b/doc/spec/grammar/lexer.l @@ -1,1401 +1,1412 @@ -/* Copyright 2012-2021, Microsoft Research, Daan Leijen - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. -*/ -/* Use the "Yash" extension in vscode for nice syntax highlighting. - Requires at least Flex 2.5.37; you can get a version for windows from - https://sourceforge.net/projects/winflexbison -*/ -%option 8bit noyywrap bison-bridge bison-locations reentrant - -/* Exclusive Lexer states */ -%x comment -%x linecomment -%x string -%x rawstring - -%{ -#define CHECK_BALANCED // check balanced parenthesis -#define INSERT_CLOSE_BRACE -#define INSERT_OPEN_BRACE -#define INDENT_LAYOUT // use full layout rule based on nested indentation -#undef LINE_LAYOUT // use simple layout based on line ending token - -/* Standard types and includes */ -typedef int bool; -#define true (1==1) -#define false (!true) - -#include "stdlib.h" -#include "string.h" -#include "stdarg.h" -#include "assert.h" -#include "parser.tab.h" - -/* The extra scanner state */ -#define YY_EXTRA_TYPE struct _ExtraState* - -/* Errors */ -void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ); -void illegal( char* s, yyscan_t scanner ); -void illegalchar( char c, char* s, yyscan_t scanner ); - -/* Comments */ -void commentNestingInc(yyscan_t scanner); -int commentNestingDec(yyscan_t scanner); - -/* Numbers */ -double numdouble( const char* s ); -long numlong( const char* s, int base ); - -/* Allocation of identifiers and string literals */ -char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ); -char* stringDup( const char* s, yyscan_t scanner ); -void stringStart( yyscan_t scanner ); -void stringAdd( unsigned int c, yyscan_t scanner); -void stringAddStr( const char* s, yyscan_t scanner ); -char* stringEnd( yyscan_t scanner ); -unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ); - -/* Raw string delimiter length */ -void rawStringSetDelimCount( int count, yyscan_t scanner ); -int rawStringGetDelimCount( yyscan_t scanner ); - -/* Character escape codes */ -char escapeToChar( char esc, yyscan_t scanner ) -{ - switch(esc) { - case 'n' : return '\n'; - case 'r' : return '\r'; - case 't' : return '\t'; - case '\\': return '\\'; - case '"' : return '"'; - case '\'': return '\''; - default : illegalchar(esc,"escape code",scanner); - return esc; - } -} - -%} - - /* Character classes */ - -Symbols {Symbol}+|[/] -Symbol [\$\%\&\*\+\@!\\\^\~=\.\-\:\?\|\<\>] -AngleBar [\<\>\|] -Angle [\<\>] -Sign [\-]? - -ConId {Upper}{IdChar}*{Final}* -Id {Lower}{IdChar}*{Final}* -IdChar {Letter}|{Digit}|[_\-] - -HexEsc x{Hex}{Hex}|u{Hex}{Hex}{Hex}{Hex}|U{Hex}{Hex}{Hex}{Hex}{Hex}{Hex} -CharEsc [nrt\\\"\'] -/* for editor highlighting " */ - -LineChar {GraphicLine}|{Utf8} -BlockChar {GraphicBlock}|{Utf8} - -Decimal 0|[1-9](_?{Digits})? -HexaDecimal 0[xX]{HexDigits} - -Digits {Digit}+{DigitSep}* -HexDigits {Hex}+{HexSep}* - -DigitSep _{Digit}+ -HexSep _{Hex}+ - -Letter {Lower}|{Upper} -Upper [A-Z] -Lower [a-z] -Digit [0-9] -Hex [0-9a-fA-F] -Space [ \t] -Newline [\r]?[\n] -Final [\'] -/* for editor highlighting ' */ - -GraphicChar [ \x21-\x26\x28-\[\]-\x7E] -GraphicStr [ \x21\x23-\[\]-\x7E] -GraphicRaw [\t \n\r\x21\x23-\x7E] -GraphicLine [\t \x21-\x7E] -GraphicBlock [\t \x21-\)\+-\.0-\x7E] - - /* Valid UTF-8 sequences. Based on http://www.w3.org/2005/03/23-lex-U - Added \xC0\x80 as a valid sequence to represent 0 (also called 'modified' utf-8) - */ -UC [\x80-\xBF] -U2 [\xC2-\xDF]{UC} -U3 [\xE0][\xA0-\xBF]{UC}|[\xE1-\xEC]{UC}{UC}|[\xED][\x80-\x9F]{UC}|[\xEE-\xEF]{UC}{UC} -U4 [\xF0][\x90-\xBF]{UC}{UC}|[\xF1-\xF3]{UC}{UC}{UC}|[\xF4][\x80-\x8F]{UC}{UC} -Utf8 {U2}|{U3}|{U4} - - -%% - - /* -------- INITIAL ------------- */ - - /* keywords */ -infix { return INFIX; } -infixl { return INFIXL; } -infixr { return INFIXR; } - -type { return TYPE; } -alias { return ALIAS; } -struct { return STRUCT; } -effect { return EFFECT; } - -forall { return FORALL; } -exists { return EXISTS; } -some { return SOME; } - -abstract { return ABSTRACT; } -extern { return EXTERN; } - -fun { return FUN; } -fn { return FN; } -val { return VAL; } -var { return VAR; } -con { return CON; } - -if { return IF;} -then { return THEN; } -else { return ELSE;} -elif { return ELIF;} -with { return WITH; } -in { return IN; } -match { return MATCH;} -return { return RETURN;} - -module { return MODULE;} -import { return IMPORT;} -pub { return PUB;} -as { return AS;} - -handle { return HANDLE; } -handler { return HANDLER; } -ctl { return CTL; } -final { return FINAL; } -raw { return RAW; } -mask { return MASK; } -override { return OVERRIDE; } -named { return NAMED; } - -rec { return ID_REC; } -co { return ID_CO; } -open { return ID_OPEN; } -extend { return ID_EXTEND; } -linear { return ID_LINEAR; } -value { return ID_VALUE; } -reference { return ID_REFERENCE; } - -inline { return ID_INLINE; } -noinline { return ID_NOINLINE;} -scoped { return ID_SCOPED; } -behind { return ID_BEHIND; } -initially { return ID_INITIALLY; } -finally { return ID_FINALLY; } - - /* unused reserved identifiers */ -interface { return IFACE; } -break { return BREAK; } -continue { return CONTINUE; } -unsafe { return UNSAFE; } - - /* reserved operators */ -: { return ':'; } -= { return '='; } -\. { return '.'; } -\-\> { return RARROW; } -\<\- { return LARROW; } - - /* special operators and identifiers (not reserved but have special meaning in certain contexts) */ -:= { return ASSIGN; } -:: { return DCOLON; } -\| { return '|'; } -\< { return '<'; } -\> { return '>'; } -! { return '!'; } -\^ { return '^'; } -~ { return '~'; } - -file { return ID_FILE; } -cs { return ID_CS; } -js { return ID_JS; } -c { return ID_C; } - - /* Special symbols (cannot be an operator) */ -\) { return ')'; } -\( { return '('; } -\{ { return '{'; } -\} { return '}'; } -\[ { return '['; } -\] { return ']'; } -; { return ';'; } -, { return ','; } -` { return '`'; } - - /* Comments */ -\/\/ { BEGIN(linecomment); yymore(); } -\/\* { BEGIN(comment); commentNestingInc(yyscanner); yyless(2); yymore(); } - - /* Type operators: these are all illegal operators and should be parsed as single characters - For example, in types, we can have sequences like "<|>" where "<<", ">|<", and ">>" - should not be parsed as operator tokens. */ -\|\| { yylval->Id = identifier(yytext,yyscanner,false); return OP; } -{AngleBar}{AngleBar}+ { yyless(1); return yytext[0]; } - - /* Numbers */ -{Sign}{Decimal}\.{Digits}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{Decimal}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{Decimal}\.{Digits} { yylval->Float = numdouble(yytext); return FLOAT; } - -{Sign}{HexaDecimal}\.{HexDigits}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{HexaDecimal}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{HexaDecimal}\.{HexDigits} { yylval->Float = numdouble(yytext); return FLOAT; } - -{Sign}{HexaDecimal} { yylval->Int = numlong(yytext+2,16); return INT; } -{Sign}{Decimal} { yylval->Int = numlong(yytext,10); return INT; } - - - /* Identifiers and operators */ -({Id}\/)+{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return QCONID; } -({Id}\/)+{Id} { yylval->Id = identifier(yytext,yyscanner,true); return QID; } -({Id}\/)+\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,true); return QIDOP; } - -{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return CONID; } -{Id} { yylval->Id = identifier(yytext,yyscanner,true); return ID; } -\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,false); return IDOP; } -{Symbols} { yylval->Id = identifier(yytext,yyscanner,false); return OP; } -_{IdChar}* { yylval->Id = identifier(yytext,yyscanner,true); return WILDCARD; } - - /* Character literals */ -\'{GraphicChar}\' { yylval->Char = yytext[1]; return CHAR; } -\'\\{HexEsc}\' { yylval->Char = strtol(yytext+3,NULL,16); return CHAR; } -\'\\{CharEsc}\' { yylval->Char = escapeToChar(yytext[2],yyscanner); return CHAR; } -\'{Utf8}\' { yylval->Char = utfDecode(yytext+1,yyleng-2,yyscanner); return CHAR; } -\'.\' { illegalchar(yytext[1],"character literal",yyscanner); - yylval->Char = ' '; - return CHAR; - } -\'. { illegal("illegal character literal",yyscanner); // ' - yylval->Char = ' '; - return CHAR; - } - - /* String literal start */ -\" { BEGIN(string); // " - stringStart(yyscanner); - yymore(); - } - - /* Raw string literal start */ -r#*\" { BEGIN(rawstring); /* " for editor highlighting */ - rawStringSetDelimCount(yyleng-1,yyscanner); - stringStart(yyscanner); - yyless(yyleng); - yymore(); - } - - /* White space */ -{Space}+ { return LEX_WHITE; } -{Newline} { return LEX_WHITE; } -. { illegalchar(yytext[yyleng-1],NULL,yyscanner); - return LEX_WHITE; - } - - /* --------- Raw string literals --------- */ -\"#* { int count = rawStringGetDelimCount(yyscanner); - int scanned = yyleng - YY_MORE_ADJ; - if (count > scanned) { - // keep going - stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); - yymore(); - } - else { - // end of string - if (count < scanned) illegalchar('#',"raw string terminated with too many '#' characters", yyscanner); - BEGIN(INITIAL); - yylval->String = stringEnd(yyscanner); - return STRING; - } - } -{GraphicRaw}+ { stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); - yymore(); - } -{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner), yyscanner); yymore(); } -. { illegalchar(yytext[yyleng-1],"raw string", yyscanner); - yymore(); - } - - /* --------- String literals --------- */ -\" { BEGIN(INITIAL); // " - yylval->String = stringEnd(yyscanner); - return STRING; - } -{GraphicStr}+ { char* p = yytext + YY_MORE_ADJ; - while (*p) { - stringAdd( *p++, yyscanner); - } - yymore(); - } -\\{HexEsc} { stringAdd(strtol(yytext+2+YY_MORE_ADJ,NULL,16),yyscanner); yymore(); } -\\{CharEsc} { stringAdd(escapeToChar(yytext[1+YY_MORE_ADJ],yyscanner),yyscanner); yymore(); } -{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner),yyscanner); yymore(); } - -{Newline} { BEGIN(INITIAL); - illegal( "illegal newline ends string", yyscanner ); - yylval->String = stringEnd(yyscanner); - return STRING; - } -. { illegalchar(yytext[yyleng-1],"string", yyscanner); - yymore(); - } - - - /* ---------- Comments ------------ " */ -{BlockChar}+ { yymore(); } -\/\* { commentNestingInc(yyscanner); yymore(); } -\*\/ { if (commentNestingDec(yyscanner) == 0) { - BEGIN(INITIAL); - return LEX_COMMENT; - } - else yymore(); - } -\* { yymore(); } -\/ { yymore(); } -{Newline} { return LEX_COMMENT; } -. { illegalchar(yytext[yyleng-1], "comment", yyscanner); - yymore(); - } - -{LineChar}+ { yymore(); } -{Newline} { BEGIN(INITIAL); return LEX_COMMENT; } -. { illegalchar( yytext[yyleng-1], "line comment", yyscanner ); - yymore(); - } - -%% - -/* Enable the use of regular Flex macros (like yyextra) inside user defined functions */ -#define EnableMacros(s) yyget_extra(s); struct yyguts_t* yyg = (struct yyguts_t*)(s); - - -/* Keep a list of allocated memory - in order to free all allocated identifiers and string literals afterwards*/ -typedef struct _allocList* allocList; - -void alistAdd ( allocList* list, void* p ); -void alistFree( allocList* list ); - -// show character or string -char* showChar( unsigned int c, yyscan_t scanner ); -char* showString( const char* s, yyscan_t scanner ); - -/*--------------------------------------------------------- - The extra state - This is used to maintain: - - nesting level of comments - - the precise position - - the previous token - - the layout stack for semicolon insertion - - the saved token when a semicolon was inserted - - a buffer for string literals - - an allocation list to free allocated identifiers and string literals. - - the number of errors ----------------------------------------------------------*/ -#define errorMax 1 // 25 -#define layoutMax 255 /* Limit maximal layout stack to 255 for simplicity */ -#define braceMax 255 /* maximal nesting depth of parenthesis */ -#define Token int -#define savedMax 255 - -typedef struct _ExtraState { - /* nested comments */ - int commentNesting; - - /* raw string delimiter count */ - int delimCount; - - /* precise position */ - int column; - int line; - - /* layout stack */ - bool noLayout; // apply the layout rule and insert semicolons? */ -#ifdef INDENT_LAYOUT - int layoutTop; - int layout[layoutMax]; - - /* location of the last seen comment -- used to prevent comments in indentation */ - YYLTYPE commentLoc; -#endif - -#ifdef CHECK_BALANCED - /* balanced braces */ - int braceTop; - Token braces[braceMax]; - YYLTYPE bracesLoc[braceMax]; -#endif - - /* the previous non-white token and its location */ - Token previous; - YYLTYPE previousLoc; - - /* the saved token and location: used to insert semicolons */ - int savedTop; - Token savedToken[savedMax]; - YYLTYPE savedLoc[savedMax]; - - /* temporary string buffer for string literals */ - int stringMax; - int stringLen; - char* stringBuf; - - /* list of storage for yylval allocations */ - allocList allocated; - - /* number of calls to yyerror */ - int errorCount; - - /* be verbose */ - int verbose; - - /* tab size used for error reporting */ - int tab; - -} ExtraState; - -/* Forward declarations on the state */ -YYLTYPE updateLoc( yyscan_t scanner ); /* update the location after yylex returns */ -void printToken( int token, int state, yyscan_t scanner ); /* print a token for debugging purposes */ - -/*---------------------------------------------------- - For semi-colon insertion, we look at the tokens that - end statements, and ones that continue a statement -----------------------------------------------------*/ -static int find( Token tokens[], Token token ) -{ - int i = 0; - while (tokens[i] != 0) { - if (tokens[i] == token) return i; - i++; - } - return -1; -} - -static bool contains( Token tokens[], Token token ) { - return (find(tokens,token) >= 0); -} - -static Token appTokens[] = { ')', ']', '>', ID, CONID, IDOP, QID, QCONID, QIDOP, 0 }; - -static bool isAppToken( Token token ) { - return contains(appTokens, token ); -} - - -#ifdef INDENT_LAYOUT - static Token continuationTokens[] = { ')', '>', ']', ',', '{', '}', '|', ':', '.', '=', ASSIGN, OP, THEN, ELSE, ELIF, RARROW, LARROW, 0 }; - // { THEN, ELSE, ELIF, ')', ']', '{', 0 }; - - static bool continuationToken( Token token ) { - return contains(continuationTokens, token ); - } -#endif - - -#ifdef INSERT_OPEN_BRACE - static Token endingTokens[] = { '(', '<', '[', ',', '{', '.', OP, 0 }; - - bool endingToken( Token token ) { - return contains(endingTokens,token); - } -#endif - -#ifdef LINE_LAYOUT - static Token endingTokens[] = { ID, CONID, IDOP, QIDOP, QID, QCONID, INT, FLOAT, STRING, CHAR, ')', ']', '}', '>', 0 }; - static Token continueTokens[] = { THEN, ELSE, ELIF, '=', '{', '}', ')', ']', '>', 0 }; - - bool endingToken( Token token ) { - return contains(endingTokens,token); - } - - bool continueToken( Token token ) { - return contains(continueTokens,token); - } -#endif - -#ifdef CHECK_BALANCED - static Token closeTokens[] = { ')', '}', ']', /* ')', ']',*/ 0 }; - static Token openTokens[] = { '(', '{', '[', /* APP, IDX,*/ 0 }; - - Token isCloseBrace( Token token ) { - int i = find(closeTokens,token); - return (i >= 0 ? openTokens[i] : -1); - } - - Token isOpenBrace( Token token ) { - int i = find(openTokens,token); - return (i >= 0 ? closeTokens[i] : -1); - } -#endif - - -static void savedPush( YY_EXTRA_TYPE extra, Token token, YYLTYPE* loc ) { - assert(extra->savedTop < savedMax); - extra->savedTop++; - extra->savedToken[extra->savedTop] = token; - extra->savedLoc[extra->savedTop] = *loc; - // fprintf(stderr, "save token (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, token, token, extra->savedTop ); -} - -static void savedPop( YY_EXTRA_TYPE extra, Token* token, YYLTYPE* loc ) { - assert(extra->savedTop >= 0); - *token = extra->savedToken[extra->savedTop]; - *loc = extra->savedLoc[extra->savedTop]; - extra->savedTop--; - // fprintf(stderr, "restore from saved (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, *token, *token, extra->savedTop ); -} - -/*---------------------------------------------------- - Main lexical analysis routine 'mylex' -----------------------------------------------------*/ - -Token mylex( YYSTYPE* lval, YYLTYPE* loc, yyscan_t scanner) -{ - EnableMacros(scanner); - Token token; - int startState = YYSTATE; - - // do we have a saved token? - if (yyextra->savedTop >= 0) { - // fprintf(stderr,"have saved: %d\n", yyextra->savedTop); - savedPop( yyextra, &token, loc ); - } - - // if not, scan ahead - else { - token = yylex( lval, loc, scanner ); - *loc = updateLoc( scanner ); - - /* - // this is to avoid needing semicolons - if (token=='(' && isAppToken(yyextra->previous)) token = APP; - if (token=='[' && isAppToken(yyextra->previous)) token = IDX; - */ - - // skip whitespace - while (token == LEX_WHITE || token == LEX_COMMENT) { -#ifdef INDENT_LAYOUT - // save last comment location (to check later if it was not part of indentation) - if (token == LEX_COMMENT) { - yyextra->commentLoc = *loc; - } -#endif - // scan again - token = yylex( lval, loc, scanner ); - *loc = updateLoc(scanner); - } - } - - - - if (yyextra->previous != INSERTED_SEMI) { -#ifdef CHECK_BALANCED - // check balanced braces - Token closeBrace = isOpenBrace(token); - //fprintf(stderr,"scan: %d, %d, (%d,%d)\n", token, closeBrace, loc->first_line, loc->first_column); - if (closeBrace>=0) { - if (yyextra->braceTop >= (braceMax-1)) { - yyerror(loc,scanner, "maximal nesting level of braces reached"); - } - else { - // push the close brace - yyextra->braceTop++; - yyextra->braces[yyextra->braceTop] = closeBrace; - yyextra->bracesLoc[yyextra->braceTop] = *loc; - } - } - else if (isCloseBrace(token) >= 0) { - // check if the close brace matches the context - if (yyextra->braceTop < 0) { - yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token); - } - else if (yyextra->braces[yyextra->braceTop] != token) { - YYLTYPE openLoc = yyextra->bracesLoc[yyextra->braceTop]; - // try to pop to nearest open brace; otherwise don't pop at all - int top = yyextra->braceTop-1; - while( top >= 0 && yyextra->braces[top] != token) top--; - if (top >= 0) { - // there is a matching open brace on the stack - yyerror(&openLoc, scanner, "unbalanced braces: '%c' is not closed", isCloseBrace(yyextra->braces[yyextra->braceTop]) ); - yyextra->braceTop = top-1; // pop to matching one - } - else { - // no matching brace - yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token ); //, yyextra->braces[yyextra->braceTop],openLoc.first_line,openLoc.first_column); - } - } - else { - // pop - yyextra->braceTop--; - } - } -#endif - - // Do layout ? - if (!yyextra->noLayout) - { - bool newline = (yyextra->previousLoc.last_line < loc->first_line); - -#ifdef INDENT_LAYOUT - // set a new layout context? - if (yyextra->previous == '{') { - if (token != '}' && loc->first_column <= yyextra->layout[yyextra->layoutTop]) { - yyerror(loc,scanner,"illegal layout start; the line must be indented at least as much as its enclosing layout context (column %d)", yyextra->layout[yyextra->layoutTop-1]); - } - if (yyextra->verbose) { - fprintf(stderr," layout start: %d\n", loc->first_column); - } - - if (yyextra->layoutTop == layoutMax) { - yyerror(loc,scanner,"maximal layout nesting level reached!"); - } - else { - yyextra->layoutTop++; - yyextra->layout[yyextra->layoutTop] = loc->first_column; - } - } - - // pop from the layout stack? - if (token == '}') { - if (yyextra->layoutTop <= 1) { - yyerror(loc,scanner,"unexpected closing brace"); - } - else { - if (yyextra->verbose) { - fprintf( stderr, " layout end %d\n", yyextra->layout[yyextra->layoutTop] ); - } - yyextra->layoutTop--; - } - } - - int layoutColumn = yyextra->layout[yyextra->layoutTop]; - - if (newline) { - // check comment in indentation - if (yyextra->commentLoc.last_line == loc->first_line) { - yyerror(&yyextra->commentLoc,scanner,"comments are not allowed in indentation; rewrite by putting the comment on its own line or at the end of the line"); - } - #ifndef INSERT_CLOSE_BRACE - // check layout - if (loc->first_column < layoutColumn) { - yyerror(loc,scanner,"illegal layout: the line must be indented at least as much as its enclosing layout context (column %d)", layoutColumn); - } - #else - if (token != '}' && loc->first_column < layoutColumn && yyextra->layoutTop > 1) { - // fprintf(stderr,"line (%d,%d): insert }, layout col: %d\n", loc->first_line, loc->first_column, yyextra->layoutTop); - // pop layout column - yyextra->layoutTop--; - layoutColumn = yyextra->layout[yyextra->layoutTop]; - - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by a closing brace - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = '}'; - } - #endif - } - - // insert a semi colon? - if ( // yyextra->previous != INSERTED_SEMI && - ((newline && loc->first_column == layoutColumn && !continuationToken(token)) - || token == '}' || token == 0)) - { - // fprintf(stderr,"insert semi before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by a semicolon - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = INSERTED_SEMI; - } - - // insert open brace? - else if (newline && loc->first_column > layoutColumn && - !endingToken(yyextra->previous) && !continuationToken(token)) - { - // fprintf(stderr,"insert { before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by an open brace - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = '{'; - } -#endif -#ifdef LINE_LAYOUT // simple semicolon insertion - if ((newline && endingToken(yyextra->previous) && !continueToken(token)) || - ((token == '}' || token == 0) && yyextra->previous != INSERTED_SEMI) ) // always insert before a '}' and eof - { - // save the currently scanned token - savedPush(yyextra,token,loc); - - // and replace it by a semicolon - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = INSERTED_SEMI; - } -#endif - } // do layout? - } // not inserted semi - - // save token for the next run to previous - yyextra->previous = token; - yyextra->previousLoc = *loc; - - // debug output - if (yyextra->verbose) { - printToken(token,startState,scanner); - } - // return our token - return token; -} - - -/*---------------------------------------------------- - Initialize the extra state -----------------------------------------------------*/ -void initLoc( YYLTYPE* loc, int x ) -{ - loc->first_line = x; - loc->first_column = x; - loc->last_line = x; - loc->last_column = x; -} - -void initScanState( ExtraState* st ) -{ - st->tab = 8; - st->commentNesting = 0; - st->delimCount = 0; - - st->noLayout = false; -#ifdef INDENT_LAYOUT - st->layoutTop = 0; - st->layout[0] = 0; - initLoc(&st->commentLoc, 0); -#endif - -#ifdef CHECK_BALANCED - st->braceTop = -1; -#endif - - st->column = 1; - st->line = 1; - - st->previous = '{'; // so the layout context starts at the first token - initLoc(&st->previousLoc, 1); - - st->savedTop = -1; - - st->stringMax = 0; - st->stringLen = 0; - st->stringBuf = NULL; - - st->allocated = NULL; - - st->errorCount = 0; - st->verbose = 0; -} - -void doneScanState( ExtraState* st ) -{ - /* free temporary string literal buffer */ - if (st->stringBuf != NULL) { - free(st->stringBuf); - st->stringMax = 0; - st->stringLen = 0; - } - - /* free all memory allocated during scanning */ - alistFree(&st->allocated); - st->allocated = NULL; -} - -/*---------------------------------------------------- - Maintain the location -----------------------------------------------------*/ -YYLTYPE updateLoc( yyscan_t scanner ) -{ - EnableMacros(scanner); - YYLTYPE loc; - int line = loc.first_line = loc.last_line = yyextra->line; - int column = loc.first_column = loc.last_column = yyextra->column; - - int i; - for(i = 0; i < yyleng; i++) { - loc.last_line = line; - loc.last_column = column; - - if (yytext[i] == '\n') { - line++; - column=1; - } - else if (yytext[i] == '\t') { - int tab = yyextra->tab; - column = (((column+tab-1)/tab)*tab)+1; - loc.last_column = column-1; // adjust in case of tabs - } - else { - column++; - } - } - yyextra->line = line; - yyextra->column = column; - return loc; -} - -YYLTYPE currentLoc( const yyscan_t scanner ) -{ - EnableMacros(scanner); - /* save */ - int line = yyextra->line; - int column = yyextra->column; - /* update */ - YYLTYPE loc = updateLoc(scanner); - /* restore */ - yyextra->line = line; - yyextra->column = column; - return loc; -} - -/*---------------------------------------------------- - Comment nesting -----------------------------------------------------*/ -void commentNestingInc(yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->commentNesting++; -} - -int commentNestingDec(yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->commentNesting--; - return yyextra->commentNesting; -} - -/*---------------------------------------------------- - Raw string delimiter count -----------------------------------------------------*/ -void rawStringSetDelimCount(int count, yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->delimCount = count; -} - -int rawStringGetDelimCount(yyscan_t scanner) -{ - EnableMacros(scanner); - return yyextra->delimCount; -} - -/*---------------------------------------------------- - Numbers -----------------------------------------------------*/ -static void filter_underscore( char* buf, const char* src, size_t bufsize ) { - size_t i = 0; - while( i < bufsize - 1 && *src != 0) { - if (*src != '_') { - buf[i++] = *src; - } - src++; - } - buf[i] = 0; -} - -double numdouble( const char* s ) { - char buf[256]; - filter_underscore(buf,s,256); - return strtod(buf, NULL); -} - -long numlong( const char* s, int base ) { - char buf[256]; - filter_underscore(buf,s,256); - return strtol(buf, NULL, base ); -} - - -/*---------------------------------------------------- - string allocation -----------------------------------------------------*/ -char* stringDup( const char* s, yyscan_t scanner ) -{ - EnableMacros(scanner); - char* t = strdup(s); - if (t==NULL) { - yyerror(yylloc,scanner,"out of memory while scanning an identifier"); - exit(1); - } - alistAdd( &yyextra->allocated, t ); - return t; -} - -/*---------------------------------------------------- - identifier allocation -----------------------------------------------------*/ - -bool isLetter(char c) { - return ((c>='a' && c <= 'z') || (c>='A' && c<='Z') || c=='\0' || c==' '); -} -bool isDigit(char c) { - return (c>='0' && c <= '9'); -} - -bool wellformed( const char* s ) { - char prev = '\0'; - char next = '\0'; - const char* c; - for(c = s; *c != 0; c++) { - next = *(c+1); - if (*c=='-' && !((isLetter(prev) || isDigit(prev)) && isLetter(next))) return false; - if (*c=='(') return true; // qualified operator, or operator name - prev = *c; - } - return true; -} - -char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ) -{ - EnableMacros(scanner); - if (wellformedCheck && !wellformed(s)) yyerror(yylloc,scanner,"malformed identifier: a dash must be preceded and followed by a letter"); - return stringDup(s,scanner); -} - - -/*---------------------------------------------------- - String literals -----------------------------------------------------*/ -void stringStart( yyscan_t scanner ) -{ - EnableMacros(scanner); - yyextra->stringLen = 0; -} - -void stringAddStr( const char* s, yyscan_t scanner) { - while (*s) { - stringAdd( *s++, scanner); - } -} - -void stringAdd( unsigned int c, yyscan_t scanner) -{ - EnableMacros(scanner); - /* reallocate if necessary (always 5 more to accomodate any UTF-8 encoding + \0 char) */ - int len = yyextra->stringLen; - - if (len >= yyextra->stringMax) { - int newsize = (yyextra->stringMax==0 ? 128 : yyextra->stringMax*2); - char* buf = (char*)malloc(newsize+5); - if (buf==NULL) { - yyerror(yylloc,scanner,"out of memory while scanning a string"); - exit(1); - } - if (yyextra->stringBuf != NULL) { - strcpy(buf,yyextra->stringBuf); - free(yyextra->stringBuf); - } - yyextra->stringBuf = buf; - yyextra->stringMax = newsize; - } - /* add the new character to the buffer */ - /* encode to (modified) UTF-8 */ - if (c == 0) { - yyextra->stringBuf[len++] = 0xC0; - yyextra->stringBuf[len++] = 0x80; - } - else if (c <= 0x7F) { - yyextra->stringBuf[len++] = c; - } - else if (c <= 0x7FF) { - yyextra->stringBuf[len++] = (0xC0 | (c >> 6)); - yyextra->stringBuf[len++] = (0x80 | (c & 0x3F)); - } - else if (c <= 0xFFFF) { - yyextra->stringBuf[len++] = 0xE0 | (c >> 12); - yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); - } - else if (c <= 0x10FFFF) { - yyextra->stringBuf[len++] = 0xF0 | (c >> 18); - yyextra->stringBuf[len++] = 0x80 | ((c >> 12) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); - } - else { - yyerror(yylloc,scanner,"illegal unicode character (0x%X)", c ); - } - /* always add a 0 at the end */ - yyextra->stringBuf[len] = 0; - yyextra->stringLen = len; -} - -char* stringEnd( yyscan_t scanner ) -{ - EnableMacros(scanner); - - char* buf = (char*)malloc((yyextra->stringLen+1)); - if (buf==NULL) { - yyerror(yylloc,scanner, "out of memory while scanning a string"); - exit(1); - } - alistAdd( &yyextra->allocated, buf); - if (yyextra->stringLen > 0) { - strcpy(buf,yyextra->stringBuf); - } - else { - buf[0] = 0; - } - return buf; -} - -/* Decode a UTF8 encoded character. - "len" should be 1 or larger, and gets set to the actual number of bytes read (<= len) - For an invalid UTF8 sequence, return the replacement character and set len to 0. */ -unsigned int utfDecode1( const char* buf, int* len ) -{ - unsigned int c = (unsigned char)(buf[0]); - if (c <= 0x7F && *len>=1) { - *len = 1; - return c; - } - else if (c >= 0xC2 && c <= 0xDF && *len>=2) { - unsigned int c1 = (unsigned char)(buf[1]); - *len = 2; - return (((c&0x1F)<<6) | (c1&0x3F)); - } - else if (c >= 0xE0 && c <= 0xEF && *len>=3) { - unsigned int c1 = (unsigned char)(buf[1]); - unsigned int c2 = (unsigned char)(buf[2]); - *len = 3; - return (((c&0x0F)<<12) | ((c1&0x3F)<<6) | (c2&0x3F)); - } - else if (c >= 0xF0 && c <= 0xF4 && *len>=4) { - unsigned int c1 = (unsigned char)(buf[1]); - unsigned int c2 = (unsigned char)(buf[2]); - unsigned int c3 = (unsigned char)(buf[3]); - *len = 4; - return (((c&0x07)<<18) | ((c1&0x3F)<<12) | ((c2&0x3F)<<6) | (c3&0x3F)); - } - else { - *len = 0; - return 0xFFFD; /* replacement character */ - } -} - -/* Decode a UTF8 encoded character */ -unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ) -{ - int scanned = len; - unsigned int c = utfDecode1( buf, &scanned ); - if (scanned != len || len == 0) { - YYLTYPE loc = currentLoc(scanner); - yyerror( &loc, scanner, "illegal UTF-8 character sequence encountered: %s", buf ); - } - return c; -} - - -/*---------------------------------------------------- - Errors -----------------------------------------------------*/ -void illegal(char* s, yyscan_t scanner ) -{ - YYLTYPE loc = currentLoc(scanner); - yyerror(&loc,scanner, s ); -} - -void illegalchar( char c, char* s, yyscan_t scanner ) -{ - YYLTYPE loc = currentLoc(scanner); - const char* schar = showChar(c,scanner); - if (s == NULL && c == '\t') { - s = "(replace tabs with spaces)"; - } - if (s == NULL || strlen(s) == 0) { - yyerror(&loc,scanner, "illegal character '%s'", schar); - } - else { - yyerror(&loc,scanner, "illegal character '%s' %s", schar, s ); - } -} - -void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ) -{ - EnableMacros(scanner); - va_list ap; - va_start(ap, s); - - // print location - if (loc->first_line >= 1) { - fprintf(stderr,"(%d,%2d)-(%d,%2d): ", loc->first_line, loc->first_column, - loc->last_line, loc->last_column); - } - - // print message - vfprintf(stderr, s, ap); - fprintf(stderr, "\n"); - - // check error count - yyextra->errorCount++; - if (yyextra->errorCount >= errorMax) { - fprintf(stderr, "maximum number of errors reached.\n" ); - exit(1); - } -} - -/*---------------------------------------------------- - Main -----------------------------------------------------*/ -int yyparse( yyscan_t scanner ); - -static bool isPrefix( const char* pre, const char* s ) { - if (pre==NULL) return true; - if (s==NULL) return (pre[0] == 0); - while (pre[0] != 0) { - if (pre[0] != s[0]) return false; - pre++; - s++; - } - return true; -} - -int main( int argc, char** argv ) -{ - /* initialize */ - yyscan_t scanner; - yylex_init( &scanner ); - EnableMacros(scanner); - - ExtraState st; - initScanState( &st ); - yyset_extra( &st, scanner ); - - /* read argument and parse */ - int arg = 1; - while (arg < argc) { - if (strcmp( argv[arg], "--nosemi") == 0) { - st.noLayout = true; - } - else if (strcmp( argv[arg], "--verbose") == 0 || strcmp(argv[arg], "-v") == 0) { - st.verbose++; - } - else if (isPrefix( "--tab=", argv[arg])) { - st.tab = atoi(argv[arg]+6); - } - else if (strcmp( argv[arg], "--help") == 0) { - yyin=NULL; - break; - } - else if (argv[arg][0] == '-') { - fprintf(stderr,"unrecognized option: %s\n", argv[arg] ); - exit(1); - } - else if (yyin != NULL) { - fprintf(stderr,"too many file parameters: %s\n", argv[arg]); - exit(1); - } - else { - yyin = fopen(argv[arg], "r"); - if (!yyin) { - fprintf(stderr,"couldn't open file: %s\n", argv[arg]); - exit(1); - } - else { - // skip UTF-8 BOM ? - bool skippedBOM = (fgetc(yyin)==0xEF && fgetc(yyin)==0xBB && fgetc(yyin)==0xBF); - if (!skippedBOM) { - fseek(yyin,0,SEEK_SET); // rewind - } - else if (st.verbose) { - fprintf(stderr,"skipped BOM\n"); - } - } - } - arg++; - } - - if (yyin==NULL) { - printf("usage: koka-parser [--nosemi|--verbose|-v] \n"); - } - else { - yyparse(scanner); - - /* destroy */ - int errorCount = st.errorCount; - int lineCount = st.line; - yylex_destroy(scanner); - doneScanState(&st); - - /* final message */ - if (errorCount == 0) { - printf("Success! (%i lines parsed)\n", lineCount); - return 0; - } - else { - printf("Failure (%i errors encountered)\n", errorCount); - return 1; - } - } -} - - - - -/*---------------------------------------------------- - Nicely print a token to stderr -----------------------------------------------------*/ -char* showChar( unsigned int c, yyscan_t scanner ) -{ - char buf[11]; /* 11 = format of \U%06X + zero byte */ - if (c >= ' ' && c <= '~' && c != '\\' && c != '\'' && c != '\"') { - sprintf(buf,"%c",c); - } - else if (c <= 0xFF) { - if (c=='\t') sprintf(buf,"\\t"); - else if (c=='\n') sprintf(buf,"\\n"); - else if (c=='\r') sprintf(buf,"\\r"); - else if (c=='\'') sprintf(buf,"\\'"); - else if (c=='\"') sprintf(buf,"\\\""); - else sprintf(buf,"\\x%02X",c); - } - else if (c <= 0xFFFF) { - sprintf(buf,"\\u%04X",c); - } - else if (c <= 0xFFFFFF) { - sprintf(buf,"\\U%06X",c); - } - else { - sprintf(buf,"\\X%08X",c); - } - return stringDup(buf,scanner); -} - -char* showString( const char* s, yyscan_t scanner ) -{ - if (s==NULL) return ""; - - const int max = 60; - char buf[max + 10 + 3 + 1]; // max + maximal character width + " .." 0 - int dest = 0; - int src = 0; - int slen = strlen(s); - buf[dest++] = '"'; - while (dest < max && s[src] != 0) { - int len = slen - src; - unsigned int c = utfDecode1(s + src,&len); - if (len==0) src++; - else src += len; - const char* schar = showChar(c,scanner); - strcpy(buf+dest,schar); - dest += strlen(schar); - } - if (s[src] == 0) { - buf[dest++] = '"'; - } - else { - buf[dest++] = ' '; - buf[dest++] = '.'; - buf[dest++] = '.'; - } - buf[dest] = 0; - return stringDup(buf,scanner); -} - -void printToken( int token, int state, yyscan_t scanner ) -{ - EnableMacros(scanner); - - fprintf(stderr,"(%2d,%2d)-(%2d,%2d) 0x%04x <%d> [", yylloc->first_line, yylloc->first_column, yylloc->last_line, yylloc->last_column, token, state ); - for(int i = 0; i <= yyextra->layoutTop; i++) { - fprintf(stderr, "%d%s", yyextra->layout[i], (i==yyextra->layoutTop ? "" : ",") ); - } - fprintf(stderr, "]: "); - switch(token) { - case ID: fprintf(stderr,"ID = '%s'", yylval->Id); break; - case CONID: fprintf(stderr,"CONID = '%s'", yylval->Id); break; - case OP: fprintf(stderr,"OP = '%s'", yylval->Id); break; - case QID: fprintf(stderr,"QID = '%s'", yylval->Id); break; - case QCONID: fprintf(stderr,"QCONID= '%s'", yylval->Id); break; - // case QOP: fprintf(stderr,"QOP = '%s'", yylval->Id); break; - case INT: fprintf(stderr,"INT = '%lu'", yylval->Int); break; - case FLOAT: fprintf(stderr,"FLOAT = '%g'", yylval->Float); break; - case CHAR: fprintf(stderr,"CHAR = '%s'", showChar(yylval->Char,scanner)); break; - case INSERTED_SEMI: fprintf(stderr,"; = (inserted)"); break; - case STRING: fprintf(stderr,"STRING(%zu) = %s", strlen(yylval->String), showString(yylval->String,scanner)); break; - default: { - if (token >= ' ' && token <= '~') - fprintf(stderr,"%c", token); - else if (token < ' ') - fprintf(stderr,"0x%x", token ); - else - fprintf(stderr,"%s", yytext); - } - } - fprintf(stderr,"\n"); -} - - - -/*--------------------------------------------------------- - The allocation list - Used to free memory allocted of identifiers and - string literals. ----------------------------------------------------------*/ -struct _allocList { - struct _allocList* next; - void* mem; -}; - -void alistAdd( allocList* list, void* p ) -{ - if (p == NULL) return; - - allocList head = (allocList)malloc(sizeof(struct _allocList)); - if (head == NULL) return; - - head->mem = p; - head->next = *list; - *list = head; -} - -void alistFree( allocList* list ) -{ - allocList head = *list; - - while (head != NULL) { - allocList next = head->next; - if (head->mem != NULL) { - free(head->mem); - } - free(head); - head = next; - } -} +/* Copyright 2012-2021, Microsoft Research, Daan Leijen + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. +*/ +/* Use the "Yash" extension in vscode for nice syntax highlighting. + Requires at least Flex 2.5.37; you can get a version for windows from + https://sourceforge.net/projects/winflexbison +*/ +%option 8bit noyywrap bison-bridge bison-locations reentrant + +/* Exclusive Lexer states */ +%x comment +%x linecomment +%x string +%x rawstring + +%{ +#define CHECK_BALANCED // check balanced parenthesis +#define INSERT_CLOSE_BRACE +#define INSERT_OPEN_BRACE +#define INDENT_LAYOUT // use full layout rule based on nested indentation +#undef LINE_LAYOUT // use simple layout based on line ending token + +/* Standard types and includes */ +typedef int bool; +#define true (1==1) +#define false (!true) + +#include "stdlib.h" +#include "string.h" +#include "stdarg.h" +#include "assert.h" +#include "parser.tab.h" + +/* The extra scanner state */ +#define YY_EXTRA_TYPE struct _ExtraState* + +/* Errors */ +void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ); +void illegal( char* s, yyscan_t scanner ); +void illegalchar( char c, char* s, yyscan_t scanner ); + +/* Comments */ +void commentNestingInc(yyscan_t scanner); +int commentNestingDec(yyscan_t scanner); + +/* Numbers */ +double numdouble( const char* s ); +long numlong( const char* s, int base ); + +/* Allocation of identifiers and string literals */ +char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ); +char* stringDup( const char* s, yyscan_t scanner ); +void stringStart( yyscan_t scanner ); +void stringAdd( unsigned int c, yyscan_t scanner); +void stringAddStr( const char* s, yyscan_t scanner ); +char* stringEnd( yyscan_t scanner ); +unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ); + +/* Raw string delimiter length */ +void rawStringSetDelimCount( int count, yyscan_t scanner ); +int rawStringGetDelimCount( yyscan_t scanner ); + +/* Character escape codes */ +char escapeToChar( char esc, yyscan_t scanner ) +{ + switch(esc) { + case 'n' : return '\n'; + case 'r' : return '\r'; + case 't' : return '\t'; + case '\\': return '\\'; + case '"' : return '"'; + case '\'': return '\''; + default : illegalchar(esc,"escape code",scanner); + return esc; + } +} + +%} + + /* Character classes */ + +Symbols {Symbol}+|[/] +Symbol [\$\%\&\*\+\@!\\\^\~=\.\-\:\?\|\<\>] +AngleBar [\<\>\|] +Angle [\<\>] +Sign [\-]? + +ConId {Upper}{IdChar}*{Final}* +Id {Lower}{IdChar}*{Final}* +IdChar {Letter}|{Digit}|[_\-] + +HexEsc x{Hex}{Hex}|u{Hex}{Hex}{Hex}{Hex}|U{Hex}{Hex}{Hex}{Hex}{Hex}{Hex} +CharEsc [nrt\\\"\'] +/* for editor highlighting " */ + +LineChar {GraphicLine}|{Utf8} +BlockChar {GraphicBlock}|{Utf8} + +Decimal 0|[1-9](_?{Digits})? +HexaDecimal 0[xX]{HexDigits} + +Digits {Digit}+{DigitSep}* +HexDigits {Hex}+{HexSep}* + +DigitSep _{Digit}+ +HexSep _{Hex}+ + +Letter {Lower}|{Upper} +Upper [A-Z] +Lower [a-z] +Digit [0-9] +Hex [0-9a-fA-F] +Space [ \t] +Newline [\r]?[\n] +Final [\'] +/* for editor highlighting ' */ + +GraphicChar [ \x21-\x26\x28-\[\]-\x7E] +GraphicStr [ \x21\x23-\[\]-\x7E] +GraphicRaw [\t \n\r\x21\x23-\x7E] +GraphicLine [\t \x21-\x7E] +GraphicBlock [\t \x21-\)\+-\.0-\x7E] + + /* Valid UTF-8 sequences. Based on http://www.w3.org/2005/03/23-lex-U + Added \xC0\x80 as a valid sequence to represent 0 (also called 'modified' utf-8) + */ +UC [\x80-\xBF] +U2 [\xC2-\xDF]{UC} +U3 [\xE0][\xA0-\xBF]{UC}|[\xE1-\xEC]{UC}{UC}|[\xED][\x80-\x9F]{UC}|[\xEE-\xEF]{UC}{UC} +U4 [\xF0][\x90-\xBF]{UC}{UC}|[\xF1-\xF3]{UC}{UC}{UC}|[\xF4][\x80-\x8F]{UC}{UC} +Utf8 {U2}|{U3}|{U4} + + +%% + + /* -------- INITIAL ------------- */ + + /* keywords */ +infix { return INFIX; } +infixl { return INFIXL; } +infixr { return INFIXR; } + +type { return TYPE; } +alias { return ALIAS; } +struct { return STRUCT; } +effect { return EFFECT; } + +forall { return FORALL; } +exists { return EXISTS; } +some { return SOME; } + +abstract { return ABSTRACT; } +extern { return EXTERN; } + +fun { return FUN; } +fn { return FN; } +val { return VAL; } +var { return VAR; } +con { return CON; } + +if { return IF;} +then { return THEN; } +else { return ELSE;} +elif { return ELIF;} +with { return WITH; } +in { return IN; } +match { return MATCH;} +return { return RETURN;} + +module { return MODULE;} +import { return IMPORT;} +pub { return PUB;} +as { return AS;} + +handle { return HANDLE; } +handler { return HANDLER; } +ctl { return CTL; } +final { return FINAL; } +raw { return RAW; } +mask { return MASK; } +override { return OVERRIDE; } +named { return NAMED; } + +rec { return ID_REC; } +co { return ID_CO; } +open { return ID_OPEN; } +extend { return ID_EXTEND; } +linear { return ID_LINEAR; } +value { return ID_VALUE; } +reference { return ID_REFERENCE; } + +inline { return ID_INLINE; } +noinline { return ID_NOINLINE;} +scoped { return ID_SCOPED; } +behind { return ID_BEHIND; } +initially { return ID_INITIALLY; } +finally { return ID_FINALLY; } + + /* unused reserved identifiers */ +interface { return IFACE; } +break { return BREAK; } +continue { return CONTINUE; } +unsafe { return UNSAFE; } + + /* reserved operators */ +: { return ':'; } += { return '='; } +\. { return '.'; } +\-\> { return RARROW; } +\<\- { return LARROW; } + + /* special operators and identifiers (not reserved but have special meaning in certain contexts) */ +:= { return ASSIGN; } +:: { return DCOLON; } +\| { return '|'; } +\< { return '<'; } +\> { return '>'; } +! { return '!'; } +\^ { return '^'; } +~ { return '~'; } + +file { return ID_FILE; } +cs { return ID_CS; } +js { return ID_JS; } +c { return ID_C; } + + /* Special symbols (cannot be an operator) */ +\) { return ')'; } +\( { return '('; } +\{ { return '{'; } +\} { return '}'; } +\[ { return '['; } +\] { return ']'; } +; { return ';'; } +, { return ','; } +` { return '`'; } + + /* Comments */ +\/\/ { BEGIN(linecomment); yymore(); } +\/\* { BEGIN(comment); commentNestingInc(yyscanner); yyless(2); yymore(); } + + /* Type operators: these are all illegal operators and should be parsed as single characters + For example, in types, we can have sequences like "<|>" where "<<", ">|<", and ">>" + should not be parsed as operator tokens. */ +\|\| { yylval->Id = identifier(yytext,yyscanner,false); return OP; } +{AngleBar}{AngleBar}+ { yyless(1); return yytext[0]; } + + /* Numbers */ +{Sign}{Decimal}\.{Digits}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{Decimal}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{Decimal}\.{Digits} { yylval->Float = numdouble(yytext); return FLOAT; } + +{Sign}{HexaDecimal}\.{HexDigits}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{HexaDecimal}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{HexaDecimal}\.{HexDigits} { yylval->Float = numdouble(yytext); return FLOAT; } + +{Sign}{HexaDecimal} { yylval->Int = numlong(yytext+2,16); return INT; } +{Sign}{Decimal} { yylval->Int = numlong(yytext,10); return INT; } + + + /* Identifiers and operators */ +({Id}\/)+{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return QCONID; } +({Id}\/)+{Id} { yylval->Id = identifier(yytext,yyscanner,true); return QID; } +({Id}\/)+\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,true); return QIDOP; } + +{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return CONID; } +{Id} { yylval->Id = identifier(yytext,yyscanner,true); return ID; } +\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,false); return IDOP; } +{Symbols} { yylval->Id = identifier(yytext,yyscanner,false); return OP; } +_{IdChar}* { yylval->Id = identifier(yytext,yyscanner,true); return WILDCARD; } + + /* Character literals */ +\'{GraphicChar}\' { yylval->Char = yytext[1]; return CHAR; } +\'\\{HexEsc}\' { yylval->Char = strtol(yytext+3,NULL,16); return CHAR; } +\'\\{CharEsc}\' { yylval->Char = escapeToChar(yytext[2],yyscanner); return CHAR; } +\'{Utf8}\' { yylval->Char = utfDecode(yytext+1,yyleng-2,yyscanner); return CHAR; } +\'.\' { illegalchar(yytext[1],"character literal",yyscanner); + yylval->Char = ' '; + return CHAR; + } +\'. { illegal("illegal character literal",yyscanner); // ' + yylval->Char = ' '; + return CHAR; + } + + /* String literal start */ +\" { BEGIN(string); // " + stringStart(yyscanner); + yymore(); + } + + /* Raw string literal start */ +r#*\" { BEGIN(rawstring); /* " for editor highlighting */ + rawStringSetDelimCount(yyleng-1,yyscanner); + stringStart(yyscanner); + yyless(yyleng); + yymore(); + } + + /* White space */ +{Space}+ { return LEX_WHITE; } +{Newline} { return LEX_WHITE; } +. { illegalchar(yytext[yyleng-1],NULL,yyscanner); + return LEX_WHITE; + } + + /* --------- Raw string literals --------- */ +\"#* { int count = rawStringGetDelimCount(yyscanner); + int scanned = yyleng - YY_MORE_ADJ; + if (count > scanned) { + // keep going + stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); + yymore(); + } + else { + // end of string + if (count < scanned) illegalchar('#',"raw string terminated with too many '#' characters", yyscanner); + BEGIN(INITIAL); + yylval->String = stringEnd(yyscanner); + return STRING; + } + } +{GraphicRaw}+ { stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); + yymore(); + } +{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner), yyscanner); yymore(); } +. { illegalchar(yytext[yyleng-1],"raw string", yyscanner); + yymore(); + } + + /* --------- String literals --------- */ +\" { BEGIN(INITIAL); // " + yylval->String = stringEnd(yyscanner); + return STRING; + } +{GraphicStr}+ { char* p = yytext + YY_MORE_ADJ; + while (*p) { + stringAdd( *p++, yyscanner); + } + yymore(); + } +\\{HexEsc} { stringAdd(strtol(yytext+2+YY_MORE_ADJ,NULL,16),yyscanner); yymore(); } +\\{CharEsc} { stringAdd(escapeToChar(yytext[1+YY_MORE_ADJ],yyscanner),yyscanner); yymore(); } +{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner),yyscanner); yymore(); } + +{Newline} { BEGIN(INITIAL); + illegal( "illegal newline ends string", yyscanner ); + yylval->String = stringEnd(yyscanner); + return STRING; + } +. { illegalchar(yytext[yyleng-1],"string", yyscanner); + yymore(); + } + + + /* ---------- Comments ------------ " */ +{BlockChar}+ { yymore(); } +\/\* { commentNestingInc(yyscanner); yymore(); } +\*\/ { if (commentNestingDec(yyscanner) == 0) { + BEGIN(INITIAL); + return LEX_COMMENT; + } + else yymore(); + } +\* { yymore(); } +\/ { yymore(); } +{Newline} { return LEX_COMMENT; } +. { illegalchar(yytext[yyleng-1], "comment", yyscanner); + yymore(); + } + +{LineChar}+ { yymore(); } +{Newline} { BEGIN(INITIAL); return LEX_COMMENT; } +. { illegalchar( yytext[yyleng-1], "line comment", yyscanner ); + yymore(); + } + +%% + +/* Enable the use of regular Flex macros (like yyextra) inside user defined functions */ +#define EnableMacros(s) yyget_extra(s); struct yyguts_t* yyg = (struct yyguts_t*)(s); + + +/* Keep a list of allocated memory + in order to free all allocated identifiers and string literals afterwards*/ +typedef struct _allocList* allocList; + +void alistAdd ( allocList* list, void* p ); +void alistFree( allocList* list ); + +// show character or string +char* showChar( unsigned int c, yyscan_t scanner ); +char* showString( const char* s, yyscan_t scanner ); + +/*--------------------------------------------------------- + The extra state + This is used to maintain: + - nesting level of comments + - the precise position + - the previous token + - the layout stack for semicolon insertion + - the saved token when a semicolon was inserted + - a buffer for string literals + - an allocation list to free allocated identifiers and string literals. + - the number of errors +---------------------------------------------------------*/ +#define errorMax 1 // 25 +#define layoutMax 255 /* Limit maximal layout stack to 255 for simplicity */ +#define braceMax 255 /* maximal nesting depth of parenthesis */ +#define Token int +#define savedMax 255 + +typedef struct _ExtraState { + /* nested comments */ + int commentNesting; + + /* raw string delimiter count */ + int delimCount; + + /* precise position */ + int column; + int line; + + /* layout stack */ + bool noLayout; // apply the layout rule and insert semicolons? */ +#ifdef INDENT_LAYOUT + int layoutTop; + int layout[layoutMax]; + + /* location of the last seen comment -- used to prevent comments in indentation */ + YYLTYPE commentLoc; +#endif + +#ifdef CHECK_BALANCED + /* balanced braces */ + int braceTop; + Token braces[braceMax]; + YYLTYPE bracesLoc[braceMax]; +#endif + + /* the previous non-white token and its location */ + Token previous; + YYLTYPE previousLoc; + + /* the saved token and location: used to insert semicolons */ + int savedTop; + Token savedToken[savedMax]; + YYLTYPE savedLoc[savedMax]; + + /* temporary string buffer for string literals */ + int stringMax; + int stringLen; + char* stringBuf; + + /* list of storage for yylval allocations */ + allocList allocated; + + /* number of calls to yyerror */ + int errorCount; + + /* be verbose */ + int verbose; + + /* tab size used for error reporting */ + int tab; + +} ExtraState; + +/* Forward declarations on the state */ +YYLTYPE updateLoc( yyscan_t scanner ); /* update the location after yylex returns */ +void printToken( int token, int state, yyscan_t scanner ); /* print a token for debugging purposes */ + +/*---------------------------------------------------- + For semi-colon insertion, we look at the tokens that + end statements, and ones that continue a statement +----------------------------------------------------*/ +static int find( Token tokens[], Token token ) +{ + int i = 0; + while (tokens[i] != 0) { + if (tokens[i] == token) return i; + i++; + } + return -1; +} + +static bool contains( Token tokens[], Token token ) { + return (find(tokens,token) >= 0); +} + +static Token appTokens[] = { ')', ']', '>', ID, CONID, IDOP, QID, QCONID, QIDOP, 0 }; + +static bool isAppToken( Token token ) { + return contains(appTokens, token ); +} + + +#ifdef INDENT_LAYOUT + static Token continuationTokens[] = { ')', '>', ']', ',', '{', '}', '|', ':', '.', '=', ASSIGN, OP, THEN, ELSE, ELIF, RARROW, LARROW, 0 }; + // { THEN, ELSE, ELIF, ')', ']', '{', 0 }; + + static bool continuationToken( Token token ) { + return contains(continuationTokens, token ); + } +#endif + + +#ifdef INSERT_OPEN_BRACE + static Token endingTokens[] = { '(', '<', '[', ',', '{', '.', OP, 0 }; + + bool endingToken( Token token ) { + return contains(endingTokens,token); + } +#endif + +#ifdef LINE_LAYOUT + static Token endingTokens[] = { ID, CONID, IDOP, QIDOP, QID, QCONID, INT, FLOAT, STRING, CHAR, ')', ']', '}', '>', 0 }; + static Token continueTokens[] = { THEN, ELSE, ELIF, '=', '{', '}', ')', ']', '>', 0 }; + + bool endingToken( Token token ) { + return contains(endingTokens,token); + } + + bool continueToken( Token token ) { + return contains(continueTokens,token); + } +#endif + +#ifdef CHECK_BALANCED + static Token closeTokens[] = { ')', '}', ']', /* ')', ']',*/ 0 }; + static Token openTokens[] = { '(', '{', '[', /* APP, IDX,*/ 0 }; + + Token isCloseBrace( Token token ) { + int i = find(closeTokens,token); + return (i >= 0 ? openTokens[i] : -1); + } + + Token isOpenBrace( Token token ) { + int i = find(openTokens,token); + return (i >= 0 ? closeTokens[i] : -1); + } +#endif + + +static void savedPush( YY_EXTRA_TYPE extra, Token token, YYLTYPE* loc ) { + assert(extra->savedTop < savedMax); + extra->savedTop++; + extra->savedToken[extra->savedTop] = token; + extra->savedLoc[extra->savedTop] = *loc; + // fprintf(stderr, "save token (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, token, token, extra->savedTop ); +} + +static void savedPop( YY_EXTRA_TYPE extra, Token* token, YYLTYPE* loc ) { + assert(extra->savedTop >= 0); + *token = extra->savedToken[extra->savedTop]; + *loc = extra->savedLoc[extra->savedTop]; + extra->savedTop--; + // fprintf(stderr, "restore from saved (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, *token, *token, extra->savedTop ); +} + +/*---------------------------------------------------- + Main lexical analysis routine 'mylex' +----------------------------------------------------*/ + +Token mylex( YYSTYPE* lval, YYLTYPE* loc, yyscan_t scanner) +{ + EnableMacros(scanner); + Token token; + int startState = YYSTATE; + + // do we have a saved token? + if (yyextra->savedTop >= 0) { + // fprintf(stderr,"have saved: %d\n", yyextra->savedTop); + savedPop( yyextra, &token, loc ); + } + + // if not, scan ahead + else { + token = yylex( lval, loc, scanner ); + *loc = updateLoc( scanner ); + + /* + // this is to avoid needing semicolons + if (token=='(' && isAppToken(yyextra->previous)) token = APP; + if (token=='[' && isAppToken(yyextra->previous)) token = IDX; + */ + + // skip whitespace + while (token == LEX_WHITE || token == LEX_COMMENT) { +#ifdef INDENT_LAYOUT + // save last comment location (to check later if it was not part of indentation) + if (token == LEX_COMMENT) { + yyextra->commentLoc = *loc; + } +#endif + // scan again + token = yylex( lval, loc, scanner ); + *loc = updateLoc(scanner); + } + } + + + + if (yyextra->previous != INSERTED_SEMI) { +#ifdef CHECK_BALANCED + // check balanced braces + Token closeBrace = isOpenBrace(token); + //fprintf(stderr,"scan: %d, %d, (%d,%d)\n", token, closeBrace, loc->first_line, loc->first_column); + if (closeBrace>=0) { + if (yyextra->braceTop >= (braceMax-1)) { + yyerror(loc,scanner, "maximal nesting level of braces reached"); + } + else { + // push the close brace + yyextra->braceTop++; + yyextra->braces[yyextra->braceTop] = closeBrace; + yyextra->bracesLoc[yyextra->braceTop] = *loc; + } + } + else if (isCloseBrace(token) >= 0) { + // check if the close brace matches the context + if (yyextra->braceTop < 0) { + yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token); + } + else if (yyextra->braces[yyextra->braceTop] != token) { + YYLTYPE openLoc = yyextra->bracesLoc[yyextra->braceTop]; + // try to pop to nearest open brace; otherwise don't pop at all + int top = yyextra->braceTop-1; + while( top >= 0 && yyextra->braces[top] != token) top--; + if (top >= 0) { + // there is a matching open brace on the stack + yyerror(&openLoc, scanner, "unbalanced braces: '%c' is not closed", isCloseBrace(yyextra->braces[yyextra->braceTop]) ); + yyextra->braceTop = top-1; // pop to matching one + } + else { + // no matching brace + yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token ); //, yyextra->braces[yyextra->braceTop],openLoc.first_line,openLoc.first_column); + } + } + else { + // pop + yyextra->braceTop--; + } + } +#endif + + // Do layout ? + if (!yyextra->noLayout) + { + bool newline = (yyextra->previousLoc.last_line < loc->first_line); + +#ifdef INDENT_LAYOUT + // set a new layout context? + if (yyextra->previous == '{') { + if (token != '}' && loc->first_column <= yyextra->layout[yyextra->layoutTop]) { + yyerror(loc,scanner,"illegal layout start; the line must be indented at least as much as its enclosing layout context (column %d)", yyextra->layout[yyextra->layoutTop-1]); + } + if (yyextra->verbose) { + fprintf(stderr," layout start: %d\n", loc->first_column); + } + + if (yyextra->layoutTop == layoutMax) { + yyerror(loc,scanner,"maximal layout nesting level reached!"); + } + else { + yyextra->layoutTop++; + yyextra->layout[yyextra->layoutTop] = loc->first_column; + } + } + + // pop from the layout stack? + if (token == '}') { + if (yyextra->layoutTop <= 1) { + yyerror(loc,scanner,"unexpected closing brace"); + } + else { + if (yyextra->verbose) { + fprintf( stderr, " layout end %d\n", yyextra->layout[yyextra->layoutTop] ); + } + yyextra->layoutTop--; + } + } + + int layoutColumn = yyextra->layout[yyextra->layoutTop]; + + if (newline) { + // check comment in indentation + if (yyextra->commentLoc.last_line == loc->first_line) { + yyerror(&yyextra->commentLoc,scanner,"comments are not allowed in indentation; rewrite by putting the comment on its own line or at the end of the line"); + } + #ifndef INSERT_CLOSE_BRACE + // check layout + if (loc->first_column < layoutColumn) { + yyerror(loc,scanner,"illegal layout: the line must be indented at least as much as its enclosing layout context (column %d)", layoutColumn); + } + #else + if (token != '}' && loc->first_column < layoutColumn && yyextra->layoutTop > 1) { + // fprintf(stderr,"line (%d,%d): insert }, layout col: %d\n", loc->first_line, loc->first_column, yyextra->layoutTop); + // pop layout column + yyextra->layoutTop--; + layoutColumn = yyextra->layout[yyextra->layoutTop]; + + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by a closing brace + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = '}'; + } + #endif + } + + // insert a semi colon? + if ( // yyextra->previous != INSERTED_SEMI && + ((newline && loc->first_column == layoutColumn && !continuationToken(token)) + || token == '}' || token == 0)) + { + // fprintf(stderr,"insert semi before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by a semicolon + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = INSERTED_SEMI; + } + + // insert open brace? + else if (newline && loc->first_column > layoutColumn && + !endingToken(yyextra->previous) && !continuationToken(token)) + { + // fprintf(stderr,"insert { before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by an open brace + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = '{'; + } +#endif +#ifdef LINE_LAYOUT // simple semicolon insertion + if ((newline && endingToken(yyextra->previous) && !continueToken(token)) || + ((token == '}' || token == 0) && yyextra->previous != INSERTED_SEMI) ) // always insert before a '}' and eof + { + // save the currently scanned token + savedPush(yyextra,token,loc); + + // and replace it by a semicolon + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = INSERTED_SEMI; + } +#endif + } // do layout? + } // not inserted semi + + // save token for the next run to previous + yyextra->previous = token; + yyextra->previousLoc = *loc; + + // debug output + if (yyextra->verbose) { + printToken(token,startState,scanner); + } + // return our token + return token; +} + + +/*---------------------------------------------------- + Initialize the extra state +----------------------------------------------------*/ +void initLoc( YYLTYPE* loc, int x ) +{ + loc->first_line = x; + loc->first_column = x; + loc->last_line = x; + loc->last_column = x; +} + +void initScanState( ExtraState* st ) +{ + st->tab = 8; + st->commentNesting = 0; + st->delimCount = 0; + + st->noLayout = false; +#ifdef INDENT_LAYOUT + st->layoutTop = 0; + st->layout[0] = 0; + initLoc(&st->commentLoc, 0); +#endif + +#ifdef CHECK_BALANCED + st->braceTop = -1; +#endif + + st->column = 1; + st->line = 1; + + st->previous = '{'; // so the layout context starts at the first token + initLoc(&st->previousLoc, 1); + + st->savedTop = -1; + + st->stringMax = 0; + st->stringLen = 0; + st->stringBuf = NULL; + + st->allocated = NULL; + + st->errorCount = 0; + st->verbose = 0; +} + +void doneScanState( ExtraState* st ) +{ + /* free temporary string literal buffer */ + if (st->stringBuf != NULL) { + free(st->stringBuf); + st->stringMax = 0; + st->stringLen = 0; + } + + /* free all memory allocated during scanning */ + alistFree(&st->allocated); + st->allocated = NULL; +} + +/*---------------------------------------------------- + Maintain the location +----------------------------------------------------*/ +YYLTYPE updateLoc( yyscan_t scanner ) +{ + EnableMacros(scanner); + YYLTYPE loc; + int line = loc.first_line = loc.last_line = yyextra->line; + int column = loc.first_column = loc.last_column = yyextra->column; + + int i; + for(i = 0; i < yyleng; i++) { + loc.last_line = line; + loc.last_column = column; + + if (yytext[i] == '\n') { + line++; + column=1; + } + else if (yytext[i] == '\t') { + int tab = yyextra->tab; + column = (((column+tab-1)/tab)*tab)+1; + loc.last_column = column-1; // adjust in case of tabs + } + else { + column++; + } + } + yyextra->line = line; + yyextra->column = column; + return loc; +} + +YYLTYPE currentLoc( const yyscan_t scanner ) +{ + EnableMacros(scanner); + /* save */ + int line = yyextra->line; + int column = yyextra->column; + /* update */ + YYLTYPE loc = updateLoc(scanner); + /* restore */ + yyextra->line = line; + yyextra->column = column; + return loc; +} + +/*---------------------------------------------------- + Comment nesting +----------------------------------------------------*/ +void commentNestingInc(yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->commentNesting++; +} + +int commentNestingDec(yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->commentNesting--; + return yyextra->commentNesting; +} + +/*---------------------------------------------------- + Raw string delimiter count +----------------------------------------------------*/ +void rawStringSetDelimCount(int count, yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->delimCount = count; +} + +int rawStringGetDelimCount(yyscan_t scanner) +{ + EnableMacros(scanner); + return yyextra->delimCount; +} + +/*---------------------------------------------------- + Numbers +----------------------------------------------------*/ +static void filter_underscore( char* buf, const char* src, size_t bufsize ) { + size_t i = 0; + while( i < bufsize - 1 && *src != 0) { + if (*src != '_') { + buf[i++] = *src; + } + src++; + } + buf[i] = 0; +} + +double numdouble( const char* s ) { + char buf[256]; + filter_underscore(buf,s,256); + return strtod(buf, NULL); +} + +long numlong( const char* s, int base ) { + char buf[256]; + filter_underscore(buf,s,256); + return strtol(buf, NULL, base ); +} + + +/*---------------------------------------------------- + string allocation +----------------------------------------------------*/ +char* stringDup( const char* s, yyscan_t scanner ) +{ + EnableMacros(scanner); + char* t = strdup(s); + if (t==NULL) { + yyerror(yylloc,scanner,"out of memory while scanning an identifier"); + exit(1); + } + alistAdd( &yyextra->allocated, t ); + return t; +} + +/*---------------------------------------------------- + identifier allocation +----------------------------------------------------*/ + +bool isLetter(char c) { + return ((c>='a' && c <= 'z') || (c>='A' && c<='Z') || c=='\0' || c==' '); +} +bool isDigit(char c) { + return (c>='0' && c <= '9'); +} + +bool wellformed( const char* s ) { + char prev = '\0'; + char next = '\0'; + const char* c; + for(c = s; *c != 0; c++) { + next = *(c+1); + if (*c=='-' && !((isLetter(prev) || isDigit(prev)) && isLetter(next))) return false; + if (*c=='(') return true; // qualified operator, or operator name + prev = *c; + } + return true; +} + +char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ) +{ + EnableMacros(scanner); + if (wellformedCheck && !wellformed(s)) yyerror(yylloc,scanner,"malformed identifier: a dash must be preceded and followed by a letter"); + return stringDup(s,scanner); +} + + +/*---------------------------------------------------- + String literals +----------------------------------------------------*/ +void stringStart( yyscan_t scanner ) +{ + EnableMacros(scanner); + yyextra->stringLen = 0; +} + +void stringAddStr( const char* s, yyscan_t scanner) { + while (*s) { + stringAdd( *s++, scanner); + } +} + +void stringAdd( unsigned int c, yyscan_t scanner) +{ + EnableMacros(scanner); + /* reallocate if necessary (always 5 more to accomodate any UTF-8 encoding + \0 char) */ + int len = yyextra->stringLen; + + if (len >= yyextra->stringMax) { + int newsize = (yyextra->stringMax==0 ? 128 : yyextra->stringMax*2); + char* buf = (char*)malloc(newsize+5); + if (buf==NULL) { + yyerror(yylloc,scanner,"out of memory while scanning a string"); + exit(1); + } + if (yyextra->stringBuf != NULL) { + strcpy(buf,yyextra->stringBuf); + free(yyextra->stringBuf); + } + yyextra->stringBuf = buf; + yyextra->stringMax = newsize; + } + /* add the new character to the buffer */ + /* encode to (modified) UTF-8 */ + if (c == 0) { + yyextra->stringBuf[len++] = 0xC0; + yyextra->stringBuf[len++] = 0x80; + } + else if (c <= 0x7F) { + yyextra->stringBuf[len++] = c; + } + else if (c <= 0x7FF) { + yyextra->stringBuf[len++] = (0xC0 | (c >> 6)); + yyextra->stringBuf[len++] = (0x80 | (c & 0x3F)); + } + else if (c <= 0xFFFF) { + yyextra->stringBuf[len++] = 0xE0 | (c >> 12); + yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); + } + else if (c <= 0x10FFFF) { + yyextra->stringBuf[len++] = 0xF0 | (c >> 18); + yyextra->stringBuf[len++] = 0x80 | ((c >> 12) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); + } + else { + yyerror(yylloc,scanner,"illegal unicode character (0x%X)", c ); + } + /* always add a 0 at the end */ + yyextra->stringBuf[len] = 0; + yyextra->stringLen = len; +} + +char* stringEnd( yyscan_t scanner ) +{ + EnableMacros(scanner); + + char* buf = (char*)malloc((yyextra->stringLen+1)); + if (buf==NULL) { + yyerror(yylloc,scanner, "out of memory while scanning a string"); + exit(1); + } + alistAdd( &yyextra->allocated, buf); + if (yyextra->stringLen > 0) { + strcpy(buf,yyextra->stringBuf); + } + else { + buf[0] = 0; + } + return buf; +} + +/* Decode a UTF8 encoded character. + "len" should be 1 or larger, and gets set to the actual number of bytes read (<= len) + For an invalid UTF8 sequence, return the replacement character and set len to 0. */ +unsigned int utfDecode1( const char* buf, int* len ) +{ + unsigned int c = (unsigned char)(buf[0]); + if (c <= 0x7F && *len>=1) { + *len = 1; + return c; + } + else if (c >= 0xC2 && c <= 0xDF && *len>=2) { + unsigned int c1 = (unsigned char)(buf[1]); + *len = 2; + return (((c&0x1F)<<6) | (c1&0x3F)); + } + else if (c >= 0xE0 && c <= 0xEF && *len>=3) { + unsigned int c1 = (unsigned char)(buf[1]); + unsigned int c2 = (unsigned char)(buf[2]); + *len = 3; + return (((c&0x0F)<<12) | ((c1&0x3F)<<6) | (c2&0x3F)); + } + else if (c >= 0xF0 && c <= 0xF4 && *len>=4) { + unsigned int c1 = (unsigned char)(buf[1]); + unsigned int c2 = (unsigned char)(buf[2]); + unsigned int c3 = (unsigned char)(buf[3]); + *len = 4; + return (((c&0x07)<<18) | ((c1&0x3F)<<12) | ((c2&0x3F)<<6) | (c3&0x3F)); + } + else { + *len = 0; + return 0xFFFD; /* replacement character */ + } +} + +/* Unsafe bidi characters */ +static bool utfIsUnsafe( unsigned int c ) { + return ((c >= 0x200E && c <= 0x200F) || + (c >= 0x202A && c <= 0x202F) || + (c >= 0x2066 && c <= 0x206B)); +} + +/* Decode a UTF8 encoded character */ +unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ) +{ + int scanned = len; + unsigned int c = utfDecode1( buf, &scanned ); + if (scanned != len || len == 0) { + YYLTYPE loc = currentLoc(scanner); + yyerror( &loc, scanner, "illegal UTF-8 character sequence encountered: %s", buf ); + } + if (utfIsUnsafe(c)) { + YYLTYPE loc = currentLoc(scanner); + yyerror( &loc, scanner, "unsafe bidi character encountered: u%4X", c ); + } + return c; +} + + +/*---------------------------------------------------- + Errors +----------------------------------------------------*/ +void illegal(char* s, yyscan_t scanner ) +{ + YYLTYPE loc = currentLoc(scanner); + yyerror(&loc,scanner, s ); +} + +void illegalchar( char c, char* s, yyscan_t scanner ) +{ + YYLTYPE loc = currentLoc(scanner); + const char* schar = showChar(c,scanner); + if (s == NULL && c == '\t') { + s = "(replace tabs with spaces)"; + } + if (s == NULL || strlen(s) == 0) { + yyerror(&loc,scanner, "illegal character '%s'", schar); + } + else { + yyerror(&loc,scanner, "illegal character '%s' %s", schar, s ); + } +} + +void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ) +{ + EnableMacros(scanner); + va_list ap; + va_start(ap, s); + + // print location + if (loc->first_line >= 1) { + fprintf(stderr,"(%d,%2d)-(%d,%2d): ", loc->first_line, loc->first_column, + loc->last_line, loc->last_column); + } + + // print message + vfprintf(stderr, s, ap); + fprintf(stderr, "\n"); + + // check error count + yyextra->errorCount++; + if (yyextra->errorCount >= errorMax) { + fprintf(stderr, "maximum number of errors reached.\n" ); + exit(1); + } +} + +/*---------------------------------------------------- + Main +----------------------------------------------------*/ +int yyparse( yyscan_t scanner ); + +static bool isPrefix( const char* pre, const char* s ) { + if (pre==NULL) return true; + if (s==NULL) return (pre[0] == 0); + while (pre[0] != 0) { + if (pre[0] != s[0]) return false; + pre++; + s++; + } + return true; +} + +int main( int argc, char** argv ) +{ + /* initialize */ + yyscan_t scanner; + yylex_init( &scanner ); + EnableMacros(scanner); + + ExtraState st; + initScanState( &st ); + yyset_extra( &st, scanner ); + + /* read argument and parse */ + int arg = 1; + while (arg < argc) { + if (strcmp( argv[arg], "--nosemi") == 0) { + st.noLayout = true; + } + else if (strcmp( argv[arg], "--verbose") == 0 || strcmp(argv[arg], "-v") == 0) { + st.verbose++; + } + else if (isPrefix( "--tab=", argv[arg])) { + st.tab = atoi(argv[arg]+6); + } + else if (strcmp( argv[arg], "--help") == 0) { + yyin=NULL; + break; + } + else if (argv[arg][0] == '-') { + fprintf(stderr,"unrecognized option: %s\n", argv[arg] ); + exit(1); + } + else if (yyin != NULL) { + fprintf(stderr,"too many file parameters: %s\n", argv[arg]); + exit(1); + } + else { + yyin = fopen(argv[arg], "r"); + if (!yyin) { + fprintf(stderr,"couldn't open file: %s\n", argv[arg]); + exit(1); + } + else { + // skip UTF-8 BOM ? + bool skippedBOM = (fgetc(yyin)==0xEF && fgetc(yyin)==0xBB && fgetc(yyin)==0xBF); + if (!skippedBOM) { + fseek(yyin,0,SEEK_SET); // rewind + } + else if (st.verbose) { + fprintf(stderr,"skipped BOM\n"); + } + } + } + arg++; + } + + if (yyin==NULL) { + printf("usage: koka-parser [--nosemi|--verbose|-v] \n"); + } + else { + yyparse(scanner); + + /* destroy */ + int errorCount = st.errorCount; + int lineCount = st.line; + yylex_destroy(scanner); + doneScanState(&st); + + /* final message */ + if (errorCount == 0) { + printf("Success! (%i lines parsed)\n", lineCount); + return 0; + } + else { + printf("Failure (%i errors encountered)\n", errorCount); + return 1; + } + } +} + + + + +/*---------------------------------------------------- + Nicely print a token to stderr +----------------------------------------------------*/ +char* showChar( unsigned int c, yyscan_t scanner ) +{ + char buf[11]; /* 11 = format of \U%06X + zero byte */ + if (c >= ' ' && c <= '~' && c != '\\' && c != '\'' && c != '\"') { + sprintf(buf,"%c",c); + } + else if (c <= 0xFF) { + if (c=='\t') sprintf(buf,"\\t"); + else if (c=='\n') sprintf(buf,"\\n"); + else if (c=='\r') sprintf(buf,"\\r"); + else if (c=='\'') sprintf(buf,"\\'"); + else if (c=='\"') sprintf(buf,"\\\""); + else sprintf(buf,"\\x%02X",c); + } + else if (c <= 0xFFFF) { + sprintf(buf,"\\u%04X",c); + } + else if (c <= 0xFFFFFF) { + sprintf(buf,"\\U%06X",c); + } + else { + sprintf(buf,"\\X%08X",c); + } + return stringDup(buf,scanner); +} + +char* showString( const char* s, yyscan_t scanner ) +{ + if (s==NULL) return ""; + + const int max = 60; + char buf[max + 10 + 3 + 1]; // max + maximal character width + " .." 0 + int dest = 0; + int src = 0; + int slen = strlen(s); + buf[dest++] = '"'; + while (dest < max && s[src] != 0) { + int len = slen - src; + unsigned int c = utfDecode1(s + src,&len); + if (len==0) src++; + else src += len; + const char* schar = showChar(c,scanner); + strcpy(buf+dest,schar); + dest += strlen(schar); + } + if (s[src] == 0) { + buf[dest++] = '"'; + } + else { + buf[dest++] = ' '; + buf[dest++] = '.'; + buf[dest++] = '.'; + } + buf[dest] = 0; + return stringDup(buf,scanner); +} + +void printToken( int token, int state, yyscan_t scanner ) +{ + EnableMacros(scanner); + + fprintf(stderr,"(%2d,%2d)-(%2d,%2d) 0x%04x <%d> [", yylloc->first_line, yylloc->first_column, yylloc->last_line, yylloc->last_column, token, state ); + for(int i = 0; i <= yyextra->layoutTop; i++) { + fprintf(stderr, "%d%s", yyextra->layout[i], (i==yyextra->layoutTop ? "" : ",") ); + } + fprintf(stderr, "]: "); + switch(token) { + case ID: fprintf(stderr,"ID = '%s'", yylval->Id); break; + case CONID: fprintf(stderr,"CONID = '%s'", yylval->Id); break; + case OP: fprintf(stderr,"OP = '%s'", yylval->Id); break; + case QID: fprintf(stderr,"QID = '%s'", yylval->Id); break; + case QCONID: fprintf(stderr,"QCONID= '%s'", yylval->Id); break; + // case QOP: fprintf(stderr,"QOP = '%s'", yylval->Id); break; + case INT: fprintf(stderr,"INT = '%lu'", yylval->Int); break; + case FLOAT: fprintf(stderr,"FLOAT = '%g'", yylval->Float); break; + case CHAR: fprintf(stderr,"CHAR = '%s'", showChar(yylval->Char,scanner)); break; + case INSERTED_SEMI: fprintf(stderr,"; = (inserted)"); break; + case STRING: fprintf(stderr,"STRING(%zu) = %s", strlen(yylval->String), showString(yylval->String,scanner)); break; + default: { + if (token >= ' ' && token <= '~') + fprintf(stderr,"%c", token); + else if (token < ' ') + fprintf(stderr,"0x%x", token ); + else + fprintf(stderr,"%s", yytext); + } + } + fprintf(stderr,"\n"); +} + + + +/*--------------------------------------------------------- + The allocation list + Used to free memory allocted of identifiers and + string literals. +---------------------------------------------------------*/ +struct _allocList { + struct _allocList* next; + void* mem; +}; + +void alistAdd( allocList* list, void* p ) +{ + if (p == NULL) return; + + allocList head = (allocList)malloc(sizeof(struct _allocList)); + if (head == NULL) return; + + head->mem = p; + head->next = *list; + *list = head; +} + +void alistFree( allocList* list ) +{ + allocList head = *list; + + while (head != NULL) { + allocList next = head->next; + if (head->mem != NULL) { + free(head->mem); + } + free(head); + head = next; + } +} diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 5a20f77f6..4b955de15 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -1,785 +1,790 @@ - -# &koka; language specification - -This is the draft language specification of the &koka; language, version v&kokaversion;\ -Currently only the lexical and context-free grammar are specified. -The [standard libraries][stdlib] are documented separately. - -[stdlib]: toc.html - -## Lexical syntax - -We define the grammar and lexical syntax of the language using standard BNF -notation where non-terminals are generated by alternative patterns: - -|~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _nonterm_ | ::= | _pattern_~1~ []{.bar} _pattern_~2~ | | -{.grammar} - -In the patterns, we use the following notations: - -|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| `terminal` | | A terminal symbol (in ascii) | -| ``x0B`` | | A character with hexadecimal code 0B | -| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``0x61..0x66``) | -|   | | | -| ( _pattern_ ) | | Grouping | -| [ _pattern_ ] | | Optional occurrence of _pattern_ | -| { _pattern_ } | | Zero or more occurrences of _pattern_ | -| { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | -| _pattern_~1~ []{.bar} _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | -|   | | | -| _pattern_~<! _diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | -| _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | -{.grammar} - - - -Care must be taken to distinguish meta-syntax such as - []{.bar} and ) -from concrete terminal symbols as ``|`` and ``)``. In the specification -the order of the productions is not important and at each point the -_longest matching lexeme_ is preferred. For example, even though -`fun` is a reserved word, the word `functional` is considered a -single identifier. A _prefix_ or _postfix_ pattern is included -when considering a longest match. -{.grammar} - -### Source code - -Source code consists of a sequence of 8-bit characters. Valid characters in -actual program code consists strictly of ASCII characters which range from 0 -to 127 and can be encoded in 7-bits. Only comments, string literals, and -character literals are allowed to contain extended 8-bit characters. - -### Encoding - -A program source is assumed to be UTF-8 encoded which allows comments, -string literals, and character literals to contain (encoded) unicode -characters. Moreover, the grammar is designed such that a lexical -analyzer and parser can directly work on source files without doing UTF-8 -decoding or unicode category identification. To further facilitate the -processing of UTF-8 encoded files the lexical analyzer ignores an initial -byte-order mark that some UTF-8 encoders insert. In particular, any -program source is allowed to start with three byte-order mark bytes -``0xEF``, ``0xBB``, and ``0xBF``, which are ignored. - -## Lexical grammar - -In the specification of the lexical grammar all white space is explicit -and there is no implicit white space between juxtaposed symbols. The -lexical token stream is generated by the non-terminal _lex_ which -consists of lexemes and whitespace. - -Before doing lexical analysis, there is a _linefeed_ character inserted -at the start and end of the input, which makes it easier to specify line -comments and directives. - -### Lexical tokens { test } - -| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| -| _lex_ | ::= | _lexeme_ []{.bar} _whitespace_ | | -| _lexeme_   | ::= | _conid_ []{.bar} _qconid_ | | -| | &bar; | _varid_ []{.bar} _qvarid_ | | -| | &bar; | _op_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _wildcard_ | | -| | &bar; | _integer_ []{.bar} _float_ []{.bar} _string_ []{.bar} _char_ | | -| | &bar; | _reserved_ []{.bar} _opreserved_ | | -| | &bar; | _special_ | | -{.grammar .lex} - -The main program consists of _whitespace_ or _lexeme_'s. The context-free -grammar will draw it's lexemes from the _lex_ production. - -### Identifiers - -|~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~| -| _anyid_ | ::= | _varid_ []{.bar} _qvarid_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _conid_ []{.bar} _qconid_ | | -|   | | | | -| _qconid_ | ::= | _modulepath_ _conid_ | | -| _qvarid_ | ::= | _modulepath_ _lowerid_ | | -| _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | -|   | | | | -| _conid_ | ::= | _upperid_ | | -| _varid_ | ::= | _lowerid_~<! _reserved_>~ | | -|   | | | | -| _lowerid_ | ::= | _lower_ _idtail_ | | -| _upperid_ | ::= | _upper_ _idtail_ | | -| _wildcard_ | ::= | ``_`` _idtail_ | | -| _typevarid_ | ::= | _letter_ [_digit_]{.many} | | -|   | | | | -| _idtail_ | ::= | [_idchar_]{.many} [_idfinal_]{.opt} | | -| _idchar_ | ::= | _letter_ []{.bar} _digit_ []{.bar} ``_`` []{.bar} ``-`` | | -| _idfinal_ | ::= | [``'``]{.many} | | -|   | | | | -| _reserved_ | ::= | `infix` []{.bar} `infixr` []{.bar} `infixl` | | -| | &bar; | ``module`` []{.bar} `import` []{.bar} `as` | | -| | &bar; | ``pub`` []{.bar} `abstract` | | -| | &bar; | `type` []{.bar} `struct` []{.bar} `alias` []{.bar} `effect` []{.bar} `con` | | -| | &bar; | `forall` []{.bar} `exists` []{.bar} `some` | | -| | &bar; | `fun` []{.bar} `fn` []{.bar} `val` []{.bar} `var` []{.bar} `extern` | | -| | &bar; | `if` []{.bar} `then` []{.bar} `else` []{.bar} `elif` | | -| | &bar; | `match` []{.bar} `return` []{.bar} `with` []{.bar} `in` | | -| | &bar; | `handle` []{.bar} `handler` []{.bar} `mask` | | -| | &bar; | `ctl` []{.bar} `final` []{.bar} `raw` | | -| | &bar; | `override` []{.bar} `named` | | -| | &bar; | `interface` []{.bar} `break` []{.bar} `continue` []{.bar} `unsafe` | (future reserved words) | -|   | | | | -| _specialid_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} `behind` | | -| | &bar; | `linear` []{.bar} `value` []{.bar} `reference` | | -| | &bar; | `inline` []{.bar} `noinline` []{.bar} `initially` []{.bar} `finally` | | -| | &bar; | `js` []{.bar} `c` []{.bar} `cs` []{.bar} `file` | | -{.grammar .lex} - -Identifiers always start with a letter, may contain underscores and -dashes, and can end with prime ticks. -Like in Haskell, constructors always begin with an uppercase -letter while regular identifiers are lowercase. The rationale is to -visibly distinguish constants from variables in pattern matches. -Here are some example of valid identifiers: -```unchecked -x -concat1 -visit-left -is-nil -x' -Cons -True -``` -To avoid confusion with the subtraction operator, the occurrences of -dashes are restricted in identifiers. After lexical analysis, only -identifiers where each dash is surrounded on both sides with a _letter_ -are accepted: - -````koka -fold-right -n-1 // illegal, a digit cannot follow a dash -n - 1 // n minus 1 -n-x-1 // illegal, a digit cannot follow a dash -n-x - 1 // identifier "n-x" minus 1 -n - x - 1 // n minus x minus 1 -```` -Qualified identifiers are prefixed with a module path. Module -paths can be partial as long as they are unambiguous. - -````koka -core/map -std/core/(&) -```` - -### Operators and symbols - -| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _qopid_ | ::= | _modulepath_ _opid_ | | -| _opid_ | ::= | `(` _symbols_ `)` | | -|   | | | | -| _op_ | ::= | _symbols_~<!\ _opreserved_[]{.bar}_optype_>~ []{.bar} ``\(&bar;&bar;\)`` | | -|   | | | | -| _symbols_ | ::= | _symbol_ [_symbol_]{.many}[]{.bar} ``/`` | | -| _symbol_ | ::= | `$` []{.bar} `%` []{.bar} ``&`` []{.bar} `*` []{.bar} `+` | | -| | &bar; | ``~`` []{.bar} ``!`` []{.bar} ``\`` []{.bar} `^` []{.bar} ``#`` | | -| | &bar; | ``=`` []{.bar} ``.`` []{.bar} ``:`` []{.bar} `-` []{.bar} `?` | | -| | &bar; | _anglebar_ | | -| _anglebar_ | ::= | ``<`` []{.bar} ``>`` []{.bar} ``\(&bar;\)`` | | -|   | | | | -| _opreserved_ | ::= | `=` []{.bar} `.` []{.bar} ``:`` []{.bar} `->` | | -| _optype_ | ::= | _anglebar_ _anglebar_ [_anglebar_]{.many} | | -|   | | | | -| _special_ | ::= | `{` []{.bar} `}` []{.bar} `(` []{.bar} `)` []{.bar} `[` []{.bar} `]` []{.bar} ``\(&bar;\)`` []{.bar} `;` []{.bar} `,` | | -|   | | | | -{.grammar .lex} - -### Literals - -|~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` (_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | -| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | -| _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | -|   | | | | -| _escape_ | ::= | ``\`` ( _charesc_ []{.bar} _hexesc_ ) | | -| _charesc_ | ::= | `n` []{.bar} `r` []{.bar} `t` []{.bar} ``\`` []{.bar} ``"`` []{.bar} ``'`` | | -| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ []{.bar} `u` [_hexdigit_]{.manyx}~4~ []{.bar} ``U`` [_hexdigit_]{.manyx}~6~ | | -|   | | | | -| _float_ | ::= | [``-``]{.opt} (decfloat []{.bar} hexfloat) | | -| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} []{.bar} _decexp_) | | -| _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | -| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} []{.bar} _hexexp_) | | -| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | -| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | -|   | | | | -| _integer_ | ::= | [``-``]{.opt} (_decimal_ []{.bar} _hexadecimal_) | | -| _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | -| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | -| _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | -| _hexdigits_ | ::= | _hexdigit_ [_hexdigit_]{.many} [``_`` _hexdigit_ [_hexdigit_]{.many}]{.many} | | -{.grammar .lex} - -### White space - -|~~~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _whitespace_ | ::= | _white_ [_white_]{.many} []{.bar} _newline_ | | -| _white_ | ::= | _space_ | | -| | &bar; | _linecomment_ []{.bar} _blockcomment_ | | -| | &bar; | _linedirective_ | | -|   | | | | -| _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | -| _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | -| _linechar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ | | -|   | | | | -| _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | [_any_]{.many}~/*[]{.bar}*/)\ [_any_]{.many}>~ | | -{.grammar .lex} - -### Character classes - -|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _letter_ | ::= | _upper_ []{.bar} _lower_ | | -| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | -| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | -| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | -| _posdigit_ | ::= | ``1..9`` | | -| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | -|   | | | | -| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | -|   | | | | -| _space_ | ::= | ``x20`` | (a space) | -| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | -| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | -| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | -| _graphic_ | ::= | ``x21``..``x7E`` | (a visible character) | -| _any_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | (in comments and raw strings) | -|   | | | | -| _utf8_ | ::= | (``xC2``..``xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0``..``xBF``) _cont_ | | -| | &bar; | (``xE1``..``xEC``) _cont_ _cont_ | | -| | &bar; | ``xED`` (``x80``..``x9F``) _cont_ | | -| | &bar; | (``xEE``..``xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90``..``xBF``) _cont_ _cont_| | -| | &bar; | (``xF1``..``xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80``..``x8F``) _cont_ _cont_| | -| _cont_ | ::= | ``x80``..``xBF`` | | -{.grammar .lex} - - -## Layout {#sec-layout} - -[Haskell]: http://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3 -[Python]: http://docs.python.org/2/reference/lexical_analysis.html -[JavaScript]: https://tc39.github.io/ecma262/#sec-rules-of-automatic-semicolon-insertion -[Scala]: http://www.scala-lang.org/old/sites/default/files/linuxsoft_archives/docu/files/ScalaReference.pdf#page=13 -[Go]: http://golang.org/ref/spec#Semicolons - - -Just like programming languages like -[Haskell], [Python], [JavaScript], [Scala], [Go], etc., there is a layout rule -which automatically adds braces and semicolons at appropriate places: - -* Any block that is _indented_ is automatically wrapped with curly braces: - ``` - fun show-messages1( msgs : list ) : console () - msgs.foreach fn(msg) - println(msg) - ``` - is elaborated to: - ```unchecked - fun show-messages1( msgs : list ) : console () { - msgs.foreach fn(msg) { - println(msg) - } - } - ``` - -* Any statements and declarations that are _aligned_ in a block are terminated with semicolons, that is: - ``` - fun show-messages2( msgs : list ) : console () - msgs.foreach fn(msg) - println(msg) - println("--") - println("done") - ``` - is fully elaborated to: - ```unchecked - fun show-messages2( msgs : list ) : console () { - msgs.foreach fn(msg){ - println(msg); - println("--"); - }; - println("done"); - } - ``` - -* Long expressions or declarations can still be indented without getting braces or semicolons - if it is clear from the start- or previous token that the line continues - an expression or declaration. Here is a contrived example: - ``` - fun eq2( x : int, - y : int ) : io bool - print("calc " ++ - "equ" ++ - "ality") - val result = if (x == y) - then True - else False - result - ``` - is elaborated to: - ```unchecked - fun eq2( x : int, - y : int ) : io bool { - print("calc " ++ - "equ" ++ - "ality"); - val result = if (x == y) - then True - else False; - result - } - ``` - Here the long string expression is indented but no braces or semicolons - are inserted as the previous lines end with an operator (`++`). - Similarly, in the `if` expression no braces or semicolons are inserted - as the indented lines start with `then` and `else` respectively. - In the parameter declaration, the `,` signifies the continuation. - More precisely, for long expressions and declarations, indented or aligned lines - do not get braced or semicolons if: - - 1. The line starts with a clear expression or declaration _start continuation token_, - namely: an operator (including `.`), `then`, `else`, `elif`, - a closing brace (`)`, `>`, `]`, or `}`), - or one of `,`, `->`, `{` , `=`, `|`, `::`, `.`, `:=`. - 2. The previous line ends with a clear expression or declaration _end continuation token_, - namely an operator (including `.`), an open brace (`(`, `<`, `[`, or `{`), or `,`. - -The layout algorithm is performed on the token stream in-between lexing -and parsing, and is independent of both. In particular, there are no intricate -dependencies with the parser (which leads to very complex layout rules, as is the -case in languages like [Haskell] or [JavaScript]). - -Moreover, in contrast to purely token-based layout rules (as in [Scala] or [Go] for example), -the visual indentation in a Koka program corresponds directly to how the compiler -interprets the statements. Many tricky layout -examples in other programming languages are often based on a mismatch between -the visual representation and how a compiler interprets the tokens -- with -&koka;'s layout rule such issues are largely avoided. - -Of course, it is still allowed to explicitly use semicolons and braces, -which can be used for example to put multiple statements on a single line: - -``` -fun equal-line( x : int, y : int ) : io bool { - print("calculate equality"); (x == y) -} -``` - -The layout algorithm also checks for invalid layouts where the layout would -not visually correspond to how the compiler interprets the tokens. In -particular, it is illegal to indent less than the layout context or to put -comments into the indentation (because of tabs or potential unicode -characters). For example, the program: - -```unchecked -fun equal( x : int, y : int ) : io bool { - print("calculate equality") - result = if (x == y) then True // wrong: too little indentation - /* wrong */ else False - result -} -``` - -is rejected. In order to facilitate code generation or source code -compression, compilers are also required to support a mode where the layout -rule is not applied and no braces or semicolons are inserted. A recognized command -line flag for that mode should be ``--nolayout``. - -### The layout algorithm - -To define the layout algorithm formally, we first establish some terminology: - -* A new line is started after every _linefeed_ character. -* Any non-_white_ token is called a _lexeme_, where a line without lexemes - is called _blank_. -* The indentation of a lexeme is the column number of its first character on - that line (starting at 1), and the indentation of a line is the indentation - of the first lexeme on the line. -* A lexeme is an _expression continuation_ if it is the first lexeme on a line, - and the lexeme is a _start continuation token_, or the previous lexeme is an - _end continuation token_ (as defined in the previous section). - -Because braces can be nested, we use a _layout stack_ of strictly -increasing indentations. The top indentation on the layout stack holds the -_layout indentation_. The initial layout stack contains the single -value 0 (which is never popped). We now proceed through the token stream -where we perform the following operations in order: first brace insertion, -then layout stack operations, and finally semicolon insertion: - -* _Brace insertion_: For each non-blank line, consider the first lexeme on the line. - If the indentation is larger than the layout indentation, and the lexeme - is not an _expression continuation_, then insert an open brace `{` before the lexeme. - If the indention is less than the layout indentation, and the lexeme is not already a - closing brace, insert a closing brace `}` before the lexeme. - -* _Layout stack operations_: If the previous lexeme was an - open brace `{` or the start of the lexical token sequence, we push the - indentation of the current lexeme on the layout stack. The pushed indentation - must be larger than the previous layout indentation (unless the current lexeme - is a closing brace). When a closing brace `}` is encountered the top - indentation is popped from the layout stack. - -* _Semicolon insertion_: For each non-blank line, the - indentation must be equal or larger to the layout indentation. - If the indentation is equal to the layout indentation, and the first - lexeme on the line is not an _expression continuation_, a semicolon - is inserted before the lexeme. - Also, a semicolon is always inserted before a closing brace `}` and - before the end of the token sequence. -{.grammar} - -As defined, braces are inserted around any indented blocks, semicolons -are inserted whenever statements or declarations are -aligned (unless the lexeme happens to be a clear expression continuation). To -simplify the grammar specification, a semicolon is also always inserted before -a closing brace and the end of the source. This allows us to specify many -grammar elements as ended by semicolons instead of separated by semicolons -which is more difficult to specify for a LALR(1) grammar. - -The layout can be implemented as a separate transformation on the lexical token -stream (see the [Haskell][HaskellLayout] implementation in the Koka compiler), -or directly as part of the lexer (see the [Flex][FlexLexer] implementation) - -### Implementation { #sec:lex-implementation } - -There is a full [Flex (Lex) implementation][FlexLexer] of lexical -analysis and the layout algorithm. -Ultimately, the Flex implementation serves as _the_ -specification, and this document and the Flex implementation should -always be in agreement. - -## Context-free syntax - -The grammar specification starts with the non terminal _module_ which draws -its lexical tokens from _lex_ where all _whitespace_ tokens are implicitly -ignored. - -### Modules - -|~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _module_~[_lex_]{.opt}~ | ::= | [_moduledecl_]{.opt} _modulebody_ | | -|   | | | | -| _moduledecl_ | ::= | _semis_ `module` _moduleid_ | | -| _moduleid_ | ::= | _qvarid_ []{.bar} _varid_ | | -|   | | | | -| _modulebody_ | ::= | `{` _semis_ _declarations_ `}` _semis_ | | -| | &bar; | _semis_ _declarations_ | | -|   | | | | -| _semis_ | ::= | [`;`]{.many} | | -| _semi_ | ::= | `;` _semis_ | | -{.grammar .parse} - -### Top level declarations - -|~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _declarations_ | ::= | [_importdecl_]{.many} [_fixitydecl_]{.many} _topdecls_ | | -|   | | | | -| _importdecl_ | ::= | [ _pub_]{.opt} `import` [_moduleid_ `=`]{.opt} _moduleid_ _semi_ | | -|   | | | | -| _fixitydecl_ | ::= | [ _pub_]{.opt} _fixity_ _integer_ _identifier_ [`,` _identifier_]{.many} _semi_ | | -| _fixity_ | ::= | `infixl` &bar; `infixr` &bar; `infix` | | -|   | | | | -| _topdecls_ | ::= | [_topdecl_ _semi_]{.many} | | -| _topdecl_ | ::= | [ _pub_]{.opt} _puredecl_ | | -| | &bar; | [ _pub_]{.opt} _aliasdecl_ | | -| | &bar; | [ _pub_]{.opt} _externdecl_ | | -| | &bar; | [ _pubabstract_]{.opt} _typedecl_ | | -| | &bar; | [ _pubabstract_]{.opt} _effectdecl_ | | -|   | | | | -| _pub_ | ::= | `pub` | | -| _pubabstract_ | ::= | `pub` &bar; `abstract` | | -{.grammar .parse} - -### Type Declarations - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _aliasdecl_ | ::= | `alias` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} `=` _type_ | | -|   | | | | -| _typedecl_ | ::= | _typemod_ `type` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_typebody_]{.opt} | | -| | &bar; | _structmod_ `struct` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_conparams_]{.opt} | | -|   | | | | -| _typemod_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} _structmod_ | | -| _structmod_ | ::= | `value` []{.bar} `reference` | | -|   | | | | -| _typeid_ | ::= | _varid_ &bar; ``[]`` &bar; `(` [`,`]{.many} `)` &bar; `<` `>` &bar; `<` [&bar;]{.koka; .code} `>` | | -|   | | | | -| _typeparams_ | ::= | `<` [_tbinders_]{.opt} `>` | | -| _tbinders_ | ::= | _tbinder_ [`,` _tbinder_]{.many} | | -| _tbinder_ | ::= | _varid_ [_kannot_]{.opt} | | -| _typebody_ | ::= | `{` _semis_ [_constructor_ _semi_]{.many} `}` | | -|   | | | | -| _constructor_ | ::= | [ _pub_]{.opt} [`con`]{.opt} _conid_ [_typeparams_]{.opt} [_conparams_]{.opt} | | -| _conparams_ | ::= | `{` _semis_ [_parameter_ _semi_]{.many} `}` | | -{.grammar .parse} - -### Value and Function Declarations - -| ~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~| -| _puredecl_ | ::= | [_inlinemod_]{.opt} `val` _valdecl_ | | -| | &bar; | [_inlinemod_]{.opt} `fun` _fundecl_ | | -| _inlinemod_ | ::= | `inline` []{.bar} `noinline` | | -|   | | | | -| _valdecl_ | ::= | _binder_ `=` _blockexpr_ | | -| _binder_ | ::= | _identifier_ [``:`` _type_]{.opt} | | -|   | | | | -| _fundecl_ | ::= | _funid_ _funbody_ | | -| _funbody_ | ::= | _funparam_ _blockexpr_ | | -| _funparam_ | ::= | [_typeparams_]{.opt} _pparameters_ [``:`` _tresult_]{.opt} [_qualifier_]{.opt} | | -| _funid_ | ::= | _identifier_ | | -| | &bar; | ``[`` [`,`]{.many} ``]`` | (indexing operator) | -|   | | | | -| _parameters_ | ::= | `(` [_parameter_ [`,` _parameter_]{.many}]{.opt} `)` | | -| _parameter_ | ::= | [_borrow_]{.opt} _paramid_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | -|   | | | | -| _pparameters_ | ::= | `(` [_pparameter_ [`,` _pparameter_]{.many}]{.opt} `)` | (pattern matching parameters) | -| _pparameter_ | ::= | [_borrow_]{.opt} _pattern_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | -|   | | | | -| _paramid_ | ::= | _identifier_ []{.bar} _wildcard_ | | -| _borrow_ | ::= | ``^`` | (not allowed from _conparams_) | -|   | | | | -| _qidentifier_ | ::= | _qvarid_ []{.bar} _qidop_ []{.bar} _identifier_ | | -| _identifier_ | ::= | _varid_ []{.bar} _idop_ | | -|   | | | | -| _qoperator_ | ::= | _op_ | | -| _qconstructor_ | ::= | _conid_ []{.bar} _qconid_ | | -{.grammar .parse} - -### Statements - -| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _block_ | ::= | ``{`` _semis_ [_statement_ _semi_]{.many} ``}`` | | -|   | | | | -| _statement_ | ::= | _decl_ | | -| | &bar; | _withstat_ | | -| | &bar; | _withstat_ `in` _expr_ | | -| | &bar; | _returnexpr_ | | -| | &bar; | _basicexpr_ | | -|   | | | | -| _decl_ | ::= | `fun` _fundecl_ | | -| | &bar; | `val` _apattern_ `=` _blockexpr_ | (local values can use a pattern binding) | -| | &bar; | `var` _binder_ ``:=`` _blockexpr_ | | -{.grammar .parse} - -### Expressions - - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _blockexpr_ | ::= | _expr_ | (_block_ is interpreted as statements) | -|   | | | | -| _expr_ | ::= | _withexpr_ | | -| | | _block_ | (interpreted as ``fn(){...}``) | -| | | _returnexpr_ | | -| | | _valexpr_ | | -| | | _basicexpr_ | | -|   | | | | -| _basicexpr_ | ::= | _ifexpr_ | | -| | &bar; | _fnexpr_ | | -| | &bar; | _matchexpr_ | | -| | &bar; | _handlerexpr_ | | -| | &bar; | _opexpr_ | | -|   | | | | -| _ifexpr_ | ::= | `if` _ntlexpr_ `then` _blockexpr_ [_elif_]{.many} [`else` _blockexpr_]{.opt} | | -| | &bar; | `if` _ntlexpr_ `return` _expr_ | | -| _elif_ | ::= | `elif` _ntlexpr_ `then` _blockexpr_ | | -|   | | | | -| _matchexpr_ | ::= | `match` _ntlexpr_ `{` _semis_ [_matchrule_ _semi_]{.many} `}` | | -| _returnexpr_ | ::= | `return` _expr_ | | -| _fnexpr_ | ::= | `fn` _funbody_ | (anonymous lambda expression) | -| _valexpr_ | ::= | `val` _apattern_ `=` _blockexpr_ `in` _expr_ | | -|   | | | | -| _withexpr_ | ::= | _withstat_ `in` _expr_ | | -| _withstat_ | ::= | `with` _basicexpr_ | | -| | | `with` _binder_ `<-` _basicexpr_ | | -| | | `with` [`override`]{.opt} _heff_ _opclause_ | (with single operation) | -| | | `with` _binder_ `<-` _heff_ _opclause_ | (with named single operation) | -{.grammar .parse} - -### Operator expressions - -For simplicity, we parse all operators as if they are left associative with -the same precedence. We assume that a separate pass in the compiler will use -the fixity declarations that are in scope to properly associate all operators -in an expressions. - -| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _opexpr_ | ::= | _prefixexpr_ [_qoperator_ _prefixexpr_]{.many} | | -| _prefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _appexpr_ | | -| _appexpr_ | ::= | _appexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | -| | &bar; | _appexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | -| | &bar; | _appexpr_ (_fnexpr_ []{.bar} _block_) | (trailing lambda expression) | -| | &bar; | _appexpr_ `.` _atom_ | | -| | &bar; | _atom_ | | -|   | | | | -| _ntlexpr_ | ::= | _ntlprefixexpr_ [_qoperator_ _ntlprefixexpr_]{.many} | (non trailing lambda expression) | -| _ntlprefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _ntlappexpr_ | | -| _ntlappexpr_ | ::= | _ntlappexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | -| | &bar; | _ntlappexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | -| | &bar; | _ntlappexpr_ `.` _atom_ | | -| | &bar; | _atom_ | | -|   | | | | -| _arguments_ | ::= | _argument_ [`,` _argument_]{.many} | | -| _argument_ | ::= | [_identifier_ `=`]{.opt} _expr_ | | -{.grammar .parse} - - -### Atomic expressions - -| ~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _atom_ | ::= | _qidentifier_ | | -| | &bar; | _qconstructor_ | | -| | &bar; | _literal_ | | -| | &bar; | _mask_ | | -| | &bar; | `(` `)` | (unit) | -| | &bar; | `(` _annexpr_ `)` | (parenthesized expression) | -| | &bar; | `(` _annexprs_ `)` | (tuple expression) | -| | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | -|   | | | | -| _literal_ | ::= | _natural_ []{.bar} _float_ []{.bar} _char_ []{.bar} _string_ | | -| _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | -|   | | | | -| _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | -| _annexpr_ | ::= | _expr_ [``:`` _typescheme_]{.opt} | | -{.grammar .parse} - -### Matching - -| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _matchrule_ | ::= | _patterns_ [``\(&bar;\)`` _expr_]{.opt} `->` _blockexpr_ | | -|   | | | | -| _apattern_ | ::= | _pattern_ [`:` _typescheme_]{.opt} | | -| _pattern_ | ::= | _identifier_ | | -| | &bar; | _identifier_ `as` _apattern_ | (named pattern) | -| | &bar; | _qconstructor_ [`(` [_patargs_]{.opt} `)`] | | -| | &bar; | `(` [_apatterns_]{.opt} `)` | (unit, parenthesized pattern, tuple pattern) | -| | &bar; | `[` [_apatterns_]{.opt} `]` | (list pattern) | -| | &bar; | _literal_ | | -| | &bar; | _wildcard_ | | -|   | | | | -| _patterns_ | ::= | _pattern_ [`,` _pattern_]{.many} | | -| _apatterns_ | ::= | _apattern_ [`,` _apattern_]{.many} | | -| _patargs_ | ::= | _patarg_ [`,` _patarg_]{.many} | | -| _patarg_ | ::= | [_identifier_ `=`]{.opt} _apattern_ | (possibly named parameter) | -{.grammar .parse} - - -### Effect Declarations - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _effectdecl_ | ::= | [_named_]{.opt} _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_opdecls_]{.opt} | | -| | &bar; | [_named_]{.opt} _effectmod_ `effect` [_typeparams_]{.opt} [_kannot_]{.opt} _opdecl_ | | -| | &bar; | _named_ _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} `in` _type_ [_opdecls_]{.opt} | | -| _effectmod_ | ::= | [`linear`]{.opt} [`rec`]{.opt} | | -| _named_ | ::= | `named` | | -|   | | | | -| _opdecls_ | ::= | `{` _semis_ [_opdecl_ _semi_]{.many} `}` | | -| _opdecl_ | ::= | [ _pub_]{.opt} `val` _identifier_ [_typeparams_]{.opt} ``:`` _tatom_ | | -| | &bar; | [ _pub_]{.opt} (`fun` []{.bar} `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | -{.grammar .parse} - -### Handler Expressions - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _handlerexpr_ | ::= | [`override`]{.opt} `handler` _heff_ _opclauses_ | | -| | &bar; | [`override`]{.opt} `handle` _heff_ `(` _expr_ `)` _opclauses_ | | -| | &bar; | `named` `handler` _heff_ _opclauses_ | | -| | &bar; | `named` `handle` _heff_ `(` _expr_ `)` _opclauses_ | | -| _heff_ | ::= | [`<` _tbasic_ `>`]{.opt} | | -|   | | | | -| _opclauses_ | ::= | `{` _semis_ [_opclausex_ _semi_]{.many} `}` | | -| | | | | -| _opclausex_ | &bar; | _opclause_ | | -| | &bar; | `finally` _blockexpr_ | | -| | &bar; | `initially` `(` _oparg_ `)` _blockexpr_ | | -|   | | | | -| _opclause_ | ::= | `val` _qidentifier_ [`:` _type_]{.opt} `=` _blockexpr_ | | -| | &bar; | `fun` _qidentifier_ _opargs_ _blockexpr_ | | -| | &bar; | [_ctlmod_]{.opt}`ctl` _qidentifier_ _opargs_ _blockexpr_ | | -| | &bar; | `return` `(` _oparg_ `)` _blockexpr_ | | -| _ctlmod_ | ::= | `final` &bar; `raw` | | -|   | | | | -| _opargs_ | ::= | `(` [_oparg_ [`,` _oparg_]{.many}]{.opt} `)` | | -| _oparg_ | ::= | _paramid_ [``:`` _type_]{.opt} | | -{.grammar .parse} - -### Type schemes - -|~~~~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~|~~~| -| _typescheme_ | ::= | _somes_ _foralls_ _tarrow_ [_qualifier_]{.opt} | | | -| _type_ | ::= | _foralls_ _tarrow_ [_qualifier_]{.opt} | | | -|   | | | | | -| _foralls_ | ::= | [`forall` _typeparams_]{.opt} | | | -| _some_ | ::= | [`some` _typeparams_]{.opt} | | | -|   | | | | | -| _qualifier_ | ::= | `with` `(` _predicates_ `)` | | | -|   | | | | | -| _predicates_ | ::= | _predicate_ [`,` _predicate_]{.many} | | | -| _predicate_ | ::= | _typeapp_ | (interface) | | -{.grammar .parse} - -### Types - -|~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _tarrow_ | ::= | _tatom_ [`->` _tresult_]{.opt} | | -| _tresult_ | ::= | _tatom_ [_tbasic_]{.opt} | | -|   | | | | -| _tatom_ | ::= | _tbasic_ | | -| | &bar; | `<` _anntype_ [`,` _anntype_]{.many} [``\(&bar;\)`` _tatom_]{.opt} `>` | | -| | &bar; | `<` `>` | | -|   | | | | -| _tbasic_ | ::= | _typeapp_ | | -| | &bar; | `(` `)` | (unit type) | -| | &bar; | `(` _tparam_ `)` | (parenthesized type or type parameter) | -| | &bar; | `(` _tparam_ [`,` _tparam_]{.many} `)` | (tuple type or parameters) | -| | &bar; | `[` _anntype_ `]` | (list type) | -|   | | | | -| _typeapp_ | ::= | _typecon_ [`<` _anntype_ [`,` _anntype_]{.many} `>`]{.opt} | | -|   | | | | -| _typecon_ | ::= | _varid_ []{.bar} _qvarid_ | | -| | &bar; | _wildcard_ | | -| | &bar; | `(` `,` [`,`]{.many} `)` | (tuple constructor) | -| | &bar; | `[` `]` | (list constructor) | -| | &bar; | `(` `->` `)` | (function constructor) | -|   | | | | -| _tparam_ | ::= | [_varid_ ``:``]{.opt} _anntype_ | | -| _anntype_ | ::= | _type_ [_kannot_]{.opt} | | -{.grammar .parse} - -### Kinds - -|~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _kannot_ | ::= | ``::`` _kind_ | | -|   | | | | -| _kind_ | ::= | `(` _kind_ [`,` _kind_]{.many} `)` `->` _kind_ | | -| | &bar; | _katom_ `->` _kind_ | | -| | &bar; | _katom_ | | -|   | | | | -| _katom_ | ::= | `V` | (value type) | -| | &bar; | `X` | (effect type) | -| | &bar; | `E` | (effect row) | -| | &bar; | `H` | (heap type) | -| | &bar; | `P` | (predicate type) | -| | &bar; | `S` | (scope type) | -| | &bar; | `HX` | (handled effect type) | -| | &bar; | `HX1` | (handled linear effect type) | -{.grammar .parse} - -### Implementation - -As a companion to the Flex lexical implementation, there is a full -Bison(Yacc) LALR(1) [implementation][BisonGrammar] -available. Again, the Bison parser functions -as _the_ specification of the grammar and this document should always -be in agreement with that implementation. - -[BisonGrammar]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/parser.y -[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.lex + +# &koka; language specification + +This is the draft language specification of the &koka; language, version v&kokaversion;\ +Currently only the lexical and context-free grammar are specified. +The [standard libraries][stdlib] are documented separately. + +[stdlib]: toc.html + +## Lexical syntax + +We define the grammar and lexical syntax of the language using standard BNF +notation where non-terminals are generated by alternative patterns: + +|~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _nonterm_ | ::= | _pattern_~1~ []{.bar} _pattern_~2~ | | +{.grammar} + +In the patterns, we use the following notations: + +|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| `terminal` | | A terminal symbol (in ascii) | +| ``x0B`` | | A character with hexadecimal code 0B | +| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``0x61..0x66``) | +|   | | | +| ( _pattern_ ) | | Grouping | +| [ _pattern_ ] | | Optional occurrence of _pattern_ | +| { _pattern_ } | | Zero or more occurrences of _pattern_ | +| { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | +| _pattern_~1~ []{.bar} _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | +|   | | | +| _pattern_~<! _diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | +| _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | +{.grammar} + + + +Care must be taken to distinguish meta-syntax such as + []{.bar} and ) +from concrete terminal symbols as ``|`` and ``)``. In the specification +the order of the productions is not important and at each point the +_longest matching lexeme_ is preferred. For example, even though +`fun` is a reserved word, the word `functional` is considered a +single identifier. A _prefix_ or _postfix_ pattern is included +when considering a longest match. +{.grammar} + +### Source code + +Source code consists of a sequence of 8-bit characters. Valid characters in +actual program code consists strictly of ASCII characters which range from 0 +to 127 and can be encoded in 7-bits. Only comments, string literals, and +character literals are allowed to contain extended 8-bit characters. + +### Encoding + +A program source is assumed to be UTF-8 encoded which allows comments, +string literals, and character literals to contain (encoded) unicode +characters. Moreover, the grammar is designed such that a lexical +analyzer and parser can directly work on source files without doing UTF-8 +decoding or unicode category identification. To further facilitate the +processing of UTF-8 encoded files the lexical analyzer ignores an initial +byte-order mark that some UTF-8 encoders insert. In particular, any +program source is allowed to start with three byte-order mark bytes +``0xEF``, ``0xBB``, and ``0xBF``, which are ignored. + +## Lexical grammar + +In the specification of the lexical grammar all white space is explicit +and there is no implicit white space between juxtaposed symbols. The +lexical token stream is generated by the non-terminal _lex_ which +consists of lexemes and whitespace. + +Before doing lexical analysis, there is a _linefeed_ character inserted +at the start and end of the input, which makes it easier to specify line +comments and directives. + +### Lexical tokens { test } + +| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| +| _lex_ | ::= | _lexeme_ []{.bar} _whitespace_ | | +| _lexeme_   | ::= | _conid_ []{.bar} _qconid_ | | +| | &bar; | _varid_ []{.bar} _qvarid_ | | +| | &bar; | _op_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _wildcard_ | | +| | &bar; | _integer_ []{.bar} _float_ []{.bar} _string_ []{.bar} _char_ | | +| | &bar; | _reserved_ []{.bar} _opreserved_ | | +| | &bar; | _special_ | | +{.grammar .lex} + +The main program consists of _whitespace_ or _lexeme_'s. The context-free +grammar will draw it's lexemes from the _lex_ production. + +### Identifiers + +|~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~| +| _anyid_ | ::= | _varid_ []{.bar} _qvarid_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _conid_ []{.bar} _qconid_ | | +|   | | | | +| _qconid_ | ::= | _modulepath_ _conid_ | | +| _qvarid_ | ::= | _modulepath_ _lowerid_ | | +| _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | +|   | | | | +| _conid_ | ::= | _upperid_ | | +| _varid_ | ::= | _lowerid_~<! _reserved_>~ | | +|   | | | | +| _lowerid_ | ::= | _lower_ _idtail_ | | +| _upperid_ | ::= | _upper_ _idtail_ | | +| _wildcard_ | ::= | ``_`` _idtail_ | | +| _typevarid_ | ::= | _letter_ [_digit_]{.many} | | +|   | | | | +| _idtail_ | ::= | [_idchar_]{.many} [_idfinal_]{.opt} | | +| _idchar_ | ::= | _letter_ []{.bar} _digit_ []{.bar} ``_`` []{.bar} ``-`` | | +| _idfinal_ | ::= | [``'``]{.many} | | +|   | | | | +| _reserved_ | ::= | `infix` []{.bar} `infixr` []{.bar} `infixl` | | +| | &bar; | ``module`` []{.bar} `import` []{.bar} `as` | | +| | &bar; | ``pub`` []{.bar} `abstract` | | +| | &bar; | `type` []{.bar} `struct` []{.bar} `alias` []{.bar} `effect` []{.bar} `con` | | +| | &bar; | `forall` []{.bar} `exists` []{.bar} `some` | | +| | &bar; | `fun` []{.bar} `fn` []{.bar} `val` []{.bar} `var` []{.bar} `extern` | | +| | &bar; | `if` []{.bar} `then` []{.bar} `else` []{.bar} `elif` | | +| | &bar; | `match` []{.bar} `return` []{.bar} `with` []{.bar} `in` | | +| | &bar; | `handle` []{.bar} `handler` []{.bar} `mask` | | +| | &bar; | `ctl` []{.bar} `final` []{.bar} `raw` | | +| | &bar; | `override` []{.bar} `named` | | +| | &bar; | `interface` []{.bar} `break` []{.bar} `continue` []{.bar} `unsafe` | (future reserved words) | +|   | | | | +| _specialid_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} `behind` | | +| | &bar; | `linear` []{.bar} `value` []{.bar} `reference` | | +| | &bar; | `inline` []{.bar} `noinline` []{.bar} `initially` []{.bar} `finally` | | +| | &bar; | `js` []{.bar} `c` []{.bar} `cs` []{.bar} `file` | | +{.grammar .lex} + +Identifiers always start with a letter, may contain underscores and +dashes, and can end with prime ticks. +Like in Haskell, constructors always begin with an uppercase +letter while regular identifiers are lowercase. The rationale is to +visibly distinguish constants from variables in pattern matches. +Here are some example of valid identifiers: +```unchecked +x +concat1 +visit-left +is-nil +x' +Cons +True +``` +To avoid confusion with the subtraction operator, the occurrences of +dashes are restricted in identifiers. After lexical analysis, only +identifiers where each dash is surrounded on both sides with a _letter_ +are accepted: + +````koka +fold-right +n-1 // illegal, a digit cannot follow a dash +n - 1 // n minus 1 +n-x-1 // illegal, a digit cannot follow a dash +n-x - 1 // identifier "n-x" minus 1 +n - x - 1 // n minus x minus 1 +```` +Qualified identifiers are prefixed with a module path. Module +paths can be partial as long as they are unambiguous. + +````koka +core/map +std/core/(&) +```` + +### Operators and symbols + +| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _qopid_ | ::= | _modulepath_ _opid_ | | +| _opid_ | ::= | `(` _symbols_ `)` | | +|   | | | | +| _op_ | ::= | _symbols_~<!\ _opreserved_[]{.bar}_optype_>~ []{.bar} ``\(&bar;&bar;\)`` | | +|   | | | | +| _symbols_ | ::= | _symbol_ [_symbol_]{.many}[]{.bar} ``/`` | | +| _symbol_ | ::= | `$` []{.bar} `%` []{.bar} ``&`` []{.bar} `*` []{.bar} `+` | | +| | &bar; | ``~`` []{.bar} ``!`` []{.bar} ``\`` []{.bar} `^` []{.bar} ``#`` | | +| | &bar; | ``=`` []{.bar} ``.`` []{.bar} ``:`` []{.bar} `-` []{.bar} `?` | | +| | &bar; | _anglebar_ | | +| _anglebar_ | ::= | ``<`` []{.bar} ``>`` []{.bar} ``\(&bar;\)`` | | +|   | | | | +| _opreserved_ | ::= | `=` []{.bar} `.` []{.bar} ``:`` []{.bar} `->` | | +| _optype_ | ::= | _anglebar_ _anglebar_ [_anglebar_]{.many} | | +|   | | | | +| _special_ | ::= | `{` []{.bar} `}` []{.bar} `(` []{.bar} `)` []{.bar} `[` []{.bar} `]` []{.bar} ``\(&bar;\)`` []{.bar} `;` []{.bar} `,` | | +|   | | | | +{.grammar .lex} + +### Literals + +|~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| +| _char_ | ::= | ``'`` (_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | +| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | +| _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | +|   | | | | +| _escape_ | ::= | ``\`` ( _charesc_ []{.bar} _hexesc_ ) | | +| _charesc_ | ::= | `n` []{.bar} `r` []{.bar} `t` []{.bar} ``\`` []{.bar} ``"`` []{.bar} ``'`` | | +| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ []{.bar} `u` [_hexdigit_]{.manyx}~4~ []{.bar} ``U`` [_hexdigit_]{.manyx}~6~ | | +|   | | | | +| _float_ | ::= | [``-``]{.opt} (decfloat []{.bar} hexfloat) | | +| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} []{.bar} _decexp_) | | +| _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | +| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} []{.bar} _hexexp_) | | +| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | +| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | +|   | | | | +| _integer_ | ::= | [``-``]{.opt} (_decimal_ []{.bar} _hexadecimal_) | | +| _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | +| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | +| _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | +| _hexdigits_ | ::= | _hexdigit_ [_hexdigit_]{.many} [``_`` _hexdigit_ [_hexdigit_]{.many}]{.many} | | +{.grammar .lex} + +### White space + +|~~~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _whitespace_ | ::= | _white_ [_white_]{.many} []{.bar} _newline_ | | +| _white_ | ::= | _space_ | | +| | &bar; | _linecomment_ []{.bar} _blockcomment_ | | +| | &bar; | _linedirective_ | | +|   | | | | +| _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | +| _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | +| _linechar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ | | +|   | | | | +| _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | +| _blockpart_ | ::= | [_any_]{.many}~/*[]{.bar}*/)\ [_any_]{.many}>~ | | +{.grammar .lex} + +### Character classes + +|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _letter_ | ::= | _upper_ []{.bar} _lower_ | | +| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | +| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | +| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | +| _posdigit_ | ::= | ``1..9`` | | +| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | +|   | | | | +| _any_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | (in comments and raw strings) | +| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | +|   | | | | +| _space_ | ::= | ``x20`` | (a space) | +| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | +| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | +| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | +| _graphic_ | ::= | ``x21..x7E`` | (a visible character) | +|   | | | | +| _utf8_ | ::= | _utf8valid_~~ | | +| _utf8valid_| ::= | (``xC2..xDF``) _cont_ | | +| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | | +| | &bar; | (``xE1..xEC``) _cont_ _cont_ | | +| | &bar; | ``xED`` (``x80..x9F``) _cont_ | | +| | &bar; | (``xEE..xEF``) _cont_ _cont_ | | +| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_| | +| | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | +| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_| | +| _cont_ | ::= | ``x80..xBF`` | | +|   | | | | +| _utf8unsafe_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | +| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A`` up to right-to-left override ``u202F``) | +| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xAB``) | (left-to-right isolate (``u2066`` up to activate symmetric swapping ``u206B``) | +{.grammar .lex} + + +## Layout {#sec-layout} + +[Haskell]: http://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3 +[Python]: http://docs.python.org/2/reference/lexical_analysis.html +[JavaScript]: https://tc39.github.io/ecma262/#sec-rules-of-automatic-semicolon-insertion +[Scala]: http://www.scala-lang.org/old/sites/default/files/linuxsoft_archives/docu/files/ScalaReference.pdf#page=13 +[Go]: http://golang.org/ref/spec#Semicolons + + +Just like programming languages like +[Haskell], [Python], [JavaScript], [Scala], [Go], etc., there is a layout rule +which automatically adds braces and semicolons at appropriate places: + +* Any block that is _indented_ is automatically wrapped with curly braces: + ``` + fun show-messages1( msgs : list ) : console () + msgs.foreach fn(msg) + println(msg) + ``` + is elaborated to: + ```unchecked + fun show-messages1( msgs : list ) : console () { + msgs.foreach fn(msg) { + println(msg) + } + } + ``` + +* Any statements and declarations that are _aligned_ in a block are terminated with semicolons, that is: + ``` + fun show-messages2( msgs : list ) : console () + msgs.foreach fn(msg) + println(msg) + println("--") + println("done") + ``` + is fully elaborated to: + ```unchecked + fun show-messages2( msgs : list ) : console () { + msgs.foreach fn(msg){ + println(msg); + println("--"); + }; + println("done"); + } + ``` + +* Long expressions or declarations can still be indented without getting braces or semicolons + if it is clear from the start- or previous token that the line continues + an expression or declaration. Here is a contrived example: + ``` + fun eq2( x : int, + y : int ) : io bool + print("calc " ++ + "equ" ++ + "ality") + val result = if (x == y) + then True + else False + result + ``` + is elaborated to: + ```unchecked + fun eq2( x : int, + y : int ) : io bool { + print("calc " ++ + "equ" ++ + "ality"); + val result = if (x == y) + then True + else False; + result + } + ``` + Here the long string expression is indented but no braces or semicolons + are inserted as the previous lines end with an operator (`++`). + Similarly, in the `if` expression no braces or semicolons are inserted + as the indented lines start with `then` and `else` respectively. + In the parameter declaration, the `,` signifies the continuation. + More precisely, for long expressions and declarations, indented or aligned lines + do not get braced or semicolons if: + + 1. The line starts with a clear expression or declaration _start continuation token_, + namely: an operator (including `.`), `then`, `else`, `elif`, + a closing brace (`)`, `>`, `]`, or `}`), + or one of `,`, `->`, `{` , `=`, `|`, `::`, `.`, `:=`. + 2. The previous line ends with a clear expression or declaration _end continuation token_, + namely an operator (including `.`), an open brace (`(`, `<`, `[`, or `{`), or `,`. + +The layout algorithm is performed on the token stream in-between lexing +and parsing, and is independent of both. In particular, there are no intricate +dependencies with the parser (which leads to very complex layout rules, as is the +case in languages like [Haskell] or [JavaScript]). + +Moreover, in contrast to purely token-based layout rules (as in [Scala] or [Go] for example), +the visual indentation in a Koka program corresponds directly to how the compiler +interprets the statements. Many tricky layout +examples in other programming languages are often based on a mismatch between +the visual representation and how a compiler interprets the tokens -- with +&koka;'s layout rule such issues are largely avoided. + +Of course, it is still allowed to explicitly use semicolons and braces, +which can be used for example to put multiple statements on a single line: + +``` +fun equal-line( x : int, y : int ) : io bool { + print("calculate equality"); (x == y) +} +``` + +The layout algorithm also checks for invalid layouts where the layout would +not visually correspond to how the compiler interprets the tokens. In +particular, it is illegal to indent less than the layout context or to put +comments into the indentation (because of tabs or potential unicode +characters). For example, the program: + +```unchecked +fun equal( x : int, y : int ) : io bool { + print("calculate equality") + result = if (x == y) then True // wrong: too little indentation + /* wrong */ else False + result +} +``` + +is rejected. In order to facilitate code generation or source code +compression, compilers are also required to support a mode where the layout +rule is not applied and no braces or semicolons are inserted. A recognized command +line flag for that mode should be ``--nolayout``. + +### The layout algorithm + +To define the layout algorithm formally, we first establish some terminology: + +* A new line is started after every _linefeed_ character. +* Any non-_white_ token is called a _lexeme_, where a line without lexemes + is called _blank_. +* The indentation of a lexeme is the column number of its first character on + that line (starting at 1), and the indentation of a line is the indentation + of the first lexeme on the line. +* A lexeme is an _expression continuation_ if it is the first lexeme on a line, + and the lexeme is a _start continuation token_, or the previous lexeme is an + _end continuation token_ (as defined in the previous section). + +Because braces can be nested, we use a _layout stack_ of strictly +increasing indentations. The top indentation on the layout stack holds the +_layout indentation_. The initial layout stack contains the single +value 0 (which is never popped). We now proceed through the token stream +where we perform the following operations in order: first brace insertion, +then layout stack operations, and finally semicolon insertion: + +* _Brace insertion_: For each non-blank line, consider the first lexeme on the line. + If the indentation is larger than the layout indentation, and the lexeme + is not an _expression continuation_, then insert an open brace `{` before the lexeme. + If the indention is less than the layout indentation, and the lexeme is not already a + closing brace, insert a closing brace `}` before the lexeme. + +* _Layout stack operations_: If the previous lexeme was an + open brace `{` or the start of the lexical token sequence, we push the + indentation of the current lexeme on the layout stack. The pushed indentation + must be larger than the previous layout indentation (unless the current lexeme + is a closing brace). When a closing brace `}` is encountered the top + indentation is popped from the layout stack. + +* _Semicolon insertion_: For each non-blank line, the + indentation must be equal or larger to the layout indentation. + If the indentation is equal to the layout indentation, and the first + lexeme on the line is not an _expression continuation_, a semicolon + is inserted before the lexeme. + Also, a semicolon is always inserted before a closing brace `}` and + before the end of the token sequence. +{.grammar} + +As defined, braces are inserted around any indented blocks, semicolons +are inserted whenever statements or declarations are +aligned (unless the lexeme happens to be a clear expression continuation). To +simplify the grammar specification, a semicolon is also always inserted before +a closing brace and the end of the source. This allows us to specify many +grammar elements as ended by semicolons instead of separated by semicolons +which is more difficult to specify for a LALR(1) grammar. + +The layout can be implemented as a separate transformation on the lexical token +stream (see the [Haskell][HaskellLayout] implementation in the Koka compiler), +or directly as part of the lexer (see the [Flex][FlexLexer] implementation) + +### Implementation { #sec:lex-implementation } + +There is a full [Flex (Lex) implementation][FlexLexer] of lexical +analysis and the layout algorithm. +Ultimately, the Flex implementation serves as _the_ +specification, and this document and the Flex implementation should +always be in agreement. + +## Context-free syntax + +The grammar specification starts with the non terminal _module_ which draws +its lexical tokens from _lex_ where all _whitespace_ tokens are implicitly +ignored. + +### Modules + +|~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _module_~[_lex_]{.opt}~ | ::= | [_moduledecl_]{.opt} _modulebody_ | | +|   | | | | +| _moduledecl_ | ::= | _semis_ `module` _moduleid_ | | +| _moduleid_ | ::= | _qvarid_ []{.bar} _varid_ | | +|   | | | | +| _modulebody_ | ::= | `{` _semis_ _declarations_ `}` _semis_ | | +| | &bar; | _semis_ _declarations_ | | +|   | | | | +| _semis_ | ::= | [`;`]{.many} | | +| _semi_ | ::= | `;` _semis_ | | +{.grammar .parse} + +### Top level declarations + +|~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _declarations_ | ::= | [_importdecl_]{.many} [_fixitydecl_]{.many} _topdecls_ | | +|   | | | | +| _importdecl_ | ::= | [ _pub_]{.opt} `import` [_moduleid_ `=`]{.opt} _moduleid_ _semi_ | | +|   | | | | +| _fixitydecl_ | ::= | [ _pub_]{.opt} _fixity_ _integer_ _identifier_ [`,` _identifier_]{.many} _semi_ | | +| _fixity_ | ::= | `infixl` &bar; `infixr` &bar; `infix` | | +|   | | | | +| _topdecls_ | ::= | [_topdecl_ _semi_]{.many} | | +| _topdecl_ | ::= | [ _pub_]{.opt} _puredecl_ | | +| | &bar; | [ _pub_]{.opt} _aliasdecl_ | | +| | &bar; | [ _pub_]{.opt} _externdecl_ | | +| | &bar; | [ _pubabstract_]{.opt} _typedecl_ | | +| | &bar; | [ _pubabstract_]{.opt} _effectdecl_ | | +|   | | | | +| _pub_ | ::= | `pub` | | +| _pubabstract_ | ::= | `pub` &bar; `abstract` | | +{.grammar .parse} + +### Type Declarations + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _aliasdecl_ | ::= | `alias` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} `=` _type_ | | +|   | | | | +| _typedecl_ | ::= | _typemod_ `type` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_typebody_]{.opt} | | +| | &bar; | _structmod_ `struct` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_conparams_]{.opt} | | +|   | | | | +| _typemod_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} _structmod_ | | +| _structmod_ | ::= | `value` []{.bar} `reference` | | +|   | | | | +| _typeid_ | ::= | _varid_ &bar; ``[]`` &bar; `(` [`,`]{.many} `)` &bar; `<` `>` &bar; `<` [&bar;]{.koka; .code} `>` | | +|   | | | | +| _typeparams_ | ::= | `<` [_tbinders_]{.opt} `>` | | +| _tbinders_ | ::= | _tbinder_ [`,` _tbinder_]{.many} | | +| _tbinder_ | ::= | _varid_ [_kannot_]{.opt} | | +| _typebody_ | ::= | `{` _semis_ [_constructor_ _semi_]{.many} `}` | | +|   | | | | +| _constructor_ | ::= | [ _pub_]{.opt} [`con`]{.opt} _conid_ [_typeparams_]{.opt} [_conparams_]{.opt} | | +| _conparams_ | ::= | `{` _semis_ [_parameter_ _semi_]{.many} `}` | | +{.grammar .parse} + +### Value and Function Declarations + +| ~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~| +| _puredecl_ | ::= | [_inlinemod_]{.opt} `val` _valdecl_ | | +| | &bar; | [_inlinemod_]{.opt} `fun` _fundecl_ | | +| _inlinemod_ | ::= | `inline` []{.bar} `noinline` | | +|   | | | | +| _valdecl_ | ::= | _binder_ `=` _blockexpr_ | | +| _binder_ | ::= | _identifier_ [``:`` _type_]{.opt} | | +|   | | | | +| _fundecl_ | ::= | _funid_ _funbody_ | | +| _funbody_ | ::= | _funparam_ _blockexpr_ | | +| _funparam_ | ::= | [_typeparams_]{.opt} _pparameters_ [``:`` _tresult_]{.opt} [_qualifier_]{.opt} | | +| _funid_ | ::= | _identifier_ | | +| | &bar; | ``[`` [`,`]{.many} ``]`` | (indexing operator) | +|   | | | | +| _parameters_ | ::= | `(` [_parameter_ [`,` _parameter_]{.many}]{.opt} `)` | | +| _parameter_ | ::= | [_borrow_]{.opt} _paramid_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | +|   | | | | +| _pparameters_ | ::= | `(` [_pparameter_ [`,` _pparameter_]{.many}]{.opt} `)` | (pattern matching parameters) | +| _pparameter_ | ::= | [_borrow_]{.opt} _pattern_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | +|   | | | | +| _paramid_ | ::= | _identifier_ []{.bar} _wildcard_ | | +| _borrow_ | ::= | ``^`` | (not allowed from _conparams_) | +|   | | | | +| _qidentifier_ | ::= | _qvarid_ []{.bar} _qidop_ []{.bar} _identifier_ | | +| _identifier_ | ::= | _varid_ []{.bar} _idop_ | | +|   | | | | +| _qoperator_ | ::= | _op_ | | +| _qconstructor_ | ::= | _conid_ []{.bar} _qconid_ | | +{.grammar .parse} + +### Statements + +| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _block_ | ::= | ``{`` _semis_ [_statement_ _semi_]{.many} ``}`` | | +|   | | | | +| _statement_ | ::= | _decl_ | | +| | &bar; | _withstat_ | | +| | &bar; | _withstat_ `in` _expr_ | | +| | &bar; | _returnexpr_ | | +| | &bar; | _basicexpr_ | | +|   | | | | +| _decl_ | ::= | `fun` _fundecl_ | | +| | &bar; | `val` _apattern_ `=` _blockexpr_ | (local values can use a pattern binding) | +| | &bar; | `var` _binder_ ``:=`` _blockexpr_ | | +{.grammar .parse} + +### Expressions + + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _blockexpr_ | ::= | _expr_ | (_block_ is interpreted as statements) | +|   | | | | +| _expr_ | ::= | _withexpr_ | | +| | | _block_ | (interpreted as ``fn(){...}``) | +| | | _returnexpr_ | | +| | | _valexpr_ | | +| | | _basicexpr_ | | +|   | | | | +| _basicexpr_ | ::= | _ifexpr_ | | +| | &bar; | _fnexpr_ | | +| | &bar; | _matchexpr_ | | +| | &bar; | _handlerexpr_ | | +| | &bar; | _opexpr_ | | +|   | | | | +| _ifexpr_ | ::= | `if` _ntlexpr_ `then` _blockexpr_ [_elif_]{.many} [`else` _blockexpr_]{.opt} | | +| | &bar; | `if` _ntlexpr_ `return` _expr_ | | +| _elif_ | ::= | `elif` _ntlexpr_ `then` _blockexpr_ | | +|   | | | | +| _matchexpr_ | ::= | `match` _ntlexpr_ `{` _semis_ [_matchrule_ _semi_]{.many} `}` | | +| _returnexpr_ | ::= | `return` _expr_ | | +| _fnexpr_ | ::= | `fn` _funbody_ | (anonymous lambda expression) | +| _valexpr_ | ::= | `val` _apattern_ `=` _blockexpr_ `in` _expr_ | | +|   | | | | +| _withexpr_ | ::= | _withstat_ `in` _expr_ | | +| _withstat_ | ::= | `with` _basicexpr_ | | +| | | `with` _binder_ `<-` _basicexpr_ | | +| | | `with` [`override`]{.opt} _heff_ _opclause_ | (with single operation) | +| | | `with` _binder_ `<-` _heff_ _opclause_ | (with named single operation) | +{.grammar .parse} + +### Operator expressions + +For simplicity, we parse all operators as if they are left associative with +the same precedence. We assume that a separate pass in the compiler will use +the fixity declarations that are in scope to properly associate all operators +in an expressions. + +| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _opexpr_ | ::= | _prefixexpr_ [_qoperator_ _prefixexpr_]{.many} | | +| _prefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _appexpr_ | | +| _appexpr_ | ::= | _appexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | +| | &bar; | _appexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | +| | &bar; | _appexpr_ (_fnexpr_ []{.bar} _block_) | (trailing lambda expression) | +| | &bar; | _appexpr_ `.` _atom_ | | +| | &bar; | _atom_ | | +|   | | | | +| _ntlexpr_ | ::= | _ntlprefixexpr_ [_qoperator_ _ntlprefixexpr_]{.many} | (non trailing lambda expression) | +| _ntlprefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _ntlappexpr_ | | +| _ntlappexpr_ | ::= | _ntlappexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | +| | &bar; | _ntlappexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | +| | &bar; | _ntlappexpr_ `.` _atom_ | | +| | &bar; | _atom_ | | +|   | | | | +| _arguments_ | ::= | _argument_ [`,` _argument_]{.many} | | +| _argument_ | ::= | [_identifier_ `=`]{.opt} _expr_ | | +{.grammar .parse} + + +### Atomic expressions + +| ~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _atom_ | ::= | _qidentifier_ | | +| | &bar; | _qconstructor_ | | +| | &bar; | _literal_ | | +| | &bar; | _mask_ | | +| | &bar; | `(` `)` | (unit) | +| | &bar; | `(` _annexpr_ `)` | (parenthesized expression) | +| | &bar; | `(` _annexprs_ `)` | (tuple expression) | +| | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | +|   | | | | +| _literal_ | ::= | _natural_ []{.bar} _float_ []{.bar} _char_ []{.bar} _string_ | | +| _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | +|   | | | | +| _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | +| _annexpr_ | ::= | _expr_ [``:`` _typescheme_]{.opt} | | +{.grammar .parse} + +### Matching + +| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _matchrule_ | ::= | _patterns_ [``\(&bar;\)`` _expr_]{.opt} `->` _blockexpr_ | | +|   | | | | +| _apattern_ | ::= | _pattern_ [`:` _typescheme_]{.opt} | | +| _pattern_ | ::= | _identifier_ | | +| | &bar; | _identifier_ `as` _apattern_ | (named pattern) | +| | &bar; | _qconstructor_ [`(` [_patargs_]{.opt} `)`] | | +| | &bar; | `(` [_apatterns_]{.opt} `)` | (unit, parenthesized pattern, tuple pattern) | +| | &bar; | `[` [_apatterns_]{.opt} `]` | (list pattern) | +| | &bar; | _literal_ | | +| | &bar; | _wildcard_ | | +|   | | | | +| _patterns_ | ::= | _pattern_ [`,` _pattern_]{.many} | | +| _apatterns_ | ::= | _apattern_ [`,` _apattern_]{.many} | | +| _patargs_ | ::= | _patarg_ [`,` _patarg_]{.many} | | +| _patarg_ | ::= | [_identifier_ `=`]{.opt} _apattern_ | (possibly named parameter) | +{.grammar .parse} + + +### Effect Declarations + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _effectdecl_ | ::= | [_named_]{.opt} _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_opdecls_]{.opt} | | +| | &bar; | [_named_]{.opt} _effectmod_ `effect` [_typeparams_]{.opt} [_kannot_]{.opt} _opdecl_ | | +| | &bar; | _named_ _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} `in` _type_ [_opdecls_]{.opt} | | +| _effectmod_ | ::= | [`linear`]{.opt} [`rec`]{.opt} | | +| _named_ | ::= | `named` | | +|   | | | | +| _opdecls_ | ::= | `{` _semis_ [_opdecl_ _semi_]{.many} `}` | | +| _opdecl_ | ::= | [ _pub_]{.opt} `val` _identifier_ [_typeparams_]{.opt} ``:`` _tatom_ | | +| | &bar; | [ _pub_]{.opt} (`fun` []{.bar} `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | +{.grammar .parse} + +### Handler Expressions + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _handlerexpr_ | ::= | [`override`]{.opt} `handler` _heff_ _opclauses_ | | +| | &bar; | [`override`]{.opt} `handle` _heff_ `(` _expr_ `)` _opclauses_ | | +| | &bar; | `named` `handler` _heff_ _opclauses_ | | +| | &bar; | `named` `handle` _heff_ `(` _expr_ `)` _opclauses_ | | +| _heff_ | ::= | [`<` _tbasic_ `>`]{.opt} | | +|   | | | | +| _opclauses_ | ::= | `{` _semis_ [_opclausex_ _semi_]{.many} `}` | | +| | | | | +| _opclausex_ | &bar; | _opclause_ | | +| | &bar; | `finally` _blockexpr_ | | +| | &bar; | `initially` `(` _oparg_ `)` _blockexpr_ | | +|   | | | | +| _opclause_ | ::= | `val` _qidentifier_ [`:` _type_]{.opt} `=` _blockexpr_ | | +| | &bar; | `fun` _qidentifier_ _opargs_ _blockexpr_ | | +| | &bar; | [_ctlmod_]{.opt}`ctl` _qidentifier_ _opargs_ _blockexpr_ | | +| | &bar; | `return` `(` _oparg_ `)` _blockexpr_ | | +| _ctlmod_ | ::= | `final` &bar; `raw` | | +|   | | | | +| _opargs_ | ::= | `(` [_oparg_ [`,` _oparg_]{.many}]{.opt} `)` | | +| _oparg_ | ::= | _paramid_ [``:`` _type_]{.opt} | | +{.grammar .parse} + +### Type schemes + +|~~~~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~|~~~| +| _typescheme_ | ::= | _somes_ _foralls_ _tarrow_ [_qualifier_]{.opt} | | | +| _type_ | ::= | _foralls_ _tarrow_ [_qualifier_]{.opt} | | | +|   | | | | | +| _foralls_ | ::= | [`forall` _typeparams_]{.opt} | | | +| _some_ | ::= | [`some` _typeparams_]{.opt} | | | +|   | | | | | +| _qualifier_ | ::= | `with` `(` _predicates_ `)` | | | +|   | | | | | +| _predicates_ | ::= | _predicate_ [`,` _predicate_]{.many} | | | +| _predicate_ | ::= | _typeapp_ | (interface) | | +{.grammar .parse} + +### Types + +|~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _tarrow_ | ::= | _tatom_ [`->` _tresult_]{.opt} | | +| _tresult_ | ::= | _tatom_ [_tbasic_]{.opt} | | +|   | | | | +| _tatom_ | ::= | _tbasic_ | | +| | &bar; | `<` _anntype_ [`,` _anntype_]{.many} [``\(&bar;\)`` _tatom_]{.opt} `>` | | +| | &bar; | `<` `>` | | +|   | | | | +| _tbasic_ | ::= | _typeapp_ | | +| | &bar; | `(` `)` | (unit type) | +| | &bar; | `(` _tparam_ `)` | (parenthesized type or type parameter) | +| | &bar; | `(` _tparam_ [`,` _tparam_]{.many} `)` | (tuple type or parameters) | +| | &bar; | `[` _anntype_ `]` | (list type) | +|   | | | | +| _typeapp_ | ::= | _typecon_ [`<` _anntype_ [`,` _anntype_]{.many} `>`]{.opt} | | +|   | | | | +| _typecon_ | ::= | _varid_ []{.bar} _qvarid_ | | +| | &bar; | _wildcard_ | | +| | &bar; | `(` `,` [`,`]{.many} `)` | (tuple constructor) | +| | &bar; | `[` `]` | (list constructor) | +| | &bar; | `(` `->` `)` | (function constructor) | +|   | | | | +| _tparam_ | ::= | [_varid_ ``:``]{.opt} _anntype_ | | +| _anntype_ | ::= | _type_ [_kannot_]{.opt} | | +{.grammar .parse} + +### Kinds + +|~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _kannot_ | ::= | ``::`` _kind_ | | +|   | | | | +| _kind_ | ::= | `(` _kind_ [`,` _kind_]{.many} `)` `->` _kind_ | | +| | &bar; | _katom_ `->` _kind_ | | +| | &bar; | _katom_ | | +|   | | | | +| _katom_ | ::= | `V` | (value type) | +| | &bar; | `X` | (effect type) | +| | &bar; | `E` | (effect row) | +| | &bar; | `H` | (heap type) | +| | &bar; | `P` | (predicate type) | +| | &bar; | `S` | (scope type) | +| | &bar; | `HX` | (handled effect type) | +| | &bar; | `HX1` | (handled linear effect type) | +{.grammar .parse} + +### Implementation + +As a companion to the Flex lexical implementation, there is a full +Bison(Yacc) LALR(1) [implementation][BisonGrammar] +available. Again, the Bison parser functions +as _the_ specification of the grammar and this document should always +be in agreement with that implementation. + +[BisonGrammar]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/parser.y +[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.lex [HaskellLayout]: https://github.com/koka-lang/koka/blob/dev/src/Syntax/Layout.hs#L178 \ No newline at end of file diff --git a/src/Syntax/Lexer.x b/src/Syntax/Lexer.x index eaa469c1d..9e634f91a 100644 --- a/src/Syntax/Lexer.x +++ b/src/Syntax/Lexer.x @@ -56,7 +56,7 @@ $charesc = [nrt\\\'\"] -- " ----------------------------------------------------------- @newline = $return?$linefeed -@utf8 = [\xC2-\xDF] $cont +@utf8valid = [\xC2-\xDF] $cont | \xE0 [\xA0-\xBF] $cont | [\xE1-\xEC] $cont $cont | \xED [\x80-\x9F] $cont @@ -65,6 +65,11 @@ $charesc = [nrt\\\'\"] -- " | [\xF1-\xF3] $cont $cont $cont | \xF4 [\x80-\x8F] $cont $cont +@utf8unsafe = \xE2 \x80 [\x8E-\x8F\xAA-\xAE] + | \xE2 \x81 [\xA6-\xAB] + +@utf8 = @utf8valid + @linechar = [$graphic$space$tab]|@utf8 @commentchar = ([$graphic$space$tab] # [\/\*])|@newline|@utf8 @@ -166,14 +171,16 @@ program :- -------------------------- -- string literals - @stringchar+ { more id } + @utf8unsafe { string $ unsafeChar "string" } + @stringchar { more id } \\$charesc { more fromCharEscB } \\@hexesc { more fromHexEscB } \" { pop $ \_ -> withmore (string LexString . B.init) } -- " @newline { pop $ \_ -> constant (LexError "string literal ended by a new line") } . { string $ \s -> LexError ("illegal character in string: " ++ show s) } - @stringraw+ { more id } + @utf8unsafe { string $ unsafeChar "raw string" } + @stringraw { more id } \"\#* { withRawDelim $ \s delim -> if (s == delim) then -- done @@ -194,21 +201,24 @@ program :- "*/" { pop $ \state -> if state==comment then more id else withmore (string $ LexComment . filter (/='\r')) } "/*" { push $ more id } - @commentchar+ { more id } + @utf8unsafe { string $ unsafeChar "comment" } + @commentchar { more id } [\/\*] { more id } . { string $ \s -> LexError ("illegal character in comment: " ++ show s) } -------------------------- -- line comments - @linechar+ { more id } + @utf8unsafe { string $ unsafeChar "line comment" } + @linechar { more id } @newline { pop $ \_ -> withmore (string $ LexComment . filter (/='\r')) } . { string $ \s -> LexError ("illegal character in line comment: " ++ show s) } -------------------------- -- line directives (ignored for now) - @linechar+ { more id } + @utf8unsafe { string $ unsafeChar "line directive" } + @linechar { more id } @newline { pop $ \_ -> withmore (string $ LexComment . filter (/='\r')) } . { string $ \s -> LexError ("illegal character in line directive: " ++ show s) } @@ -255,6 +265,10 @@ startsWith s [] = True startsWith [] _ = False startsWith (c:cs) (p:ps) = if (p==c) then startsWith cs ps else False +unsafeChar :: String -> String -> Lex +unsafeChar kind s + = LexError ("unsafe character in " ++ kind ++ ": \\u" ++ showHex 4 (fromEnum (head s))) + ----------------------------------------------------------- -- Reserved ----------------------------------------------------------- From 28fcbd1b6f5f955c5f084dbf684411fa967cad42 Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 17 Feb 2022 23:59:26 -0800 Subject: [PATCH 009/233] fix documentation --- lib/std/num/float64.kk | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 223de40fb..673f8c9b7 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -225,6 +225,7 @@ pub extern float64( f : float32 ) : float64 // > 1.337.show-hex ++ " != " ++ 1.337.f32.float64.show-hex // "0x1.5645A1CAC0831p+0 != 0x1.5645A2p+0" // ``` +// . pub fun f32( f : float64 ) : float32 f.float32 @@ -450,17 +451,16 @@ pub fun next-up( x : float64 ) : float64 // Compare floats using a total ordering on the `:float64`. // The ordering follows the `totalOrder` predicate as defined in IEEE 754-2008 exactly. // The values are ordered in following order: -// - negative quiet nan -// - negative signaling nan -// - `neginf` -// - -finite -// - -0.0 -// - +0.0 -// - finite -// - `posinf` -// - signaling nan -// - quiet nan -// +// negative quiet nan, +// negative signaling nan, +// `neginf`, +// -finite, +// -0.0, +// +0.0, +// finite, +// `posinf`, +// signaling nan, +// and quiet nan. pub fun compare( x : float64, y : float64 ) : order val bx = float64-to-bits(x) val by = float64-to-bits(y) From f8ff83c6d5e03554038e1e08c751760afbf17245 Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 10:30:42 -0800 Subject: [PATCH 010/233] small fixes to grammar --- doc/spec/grammar/lexer.l | 4 ++-- doc/spec/spec.kk.md | 11 +++++++---- src/Syntax/Lexer.x | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/doc/spec/grammar/lexer.l b/doc/spec/grammar/lexer.l index 9b2f80130..69c280ef8 100644 --- a/doc/spec/grammar/lexer.l +++ b/doc/spec/grammar/lexer.l @@ -1113,8 +1113,8 @@ unsigned int utfDecode1( const char* buf, int* len ) /* Unsafe bidi characters */ static bool utfIsUnsafe( unsigned int c ) { return ((c >= 0x200E && c <= 0x200F) || - (c >= 0x202A && c <= 0x202F) || - (c >= 0x2066 && c <= 0x206B)); + (c >= 0x202A && c <= 0x202E) || + (c >= 0x2066 && c <= 0x2069)); } /* Decode a UTF8 encoded character */ diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 4b955de15..e7a75f150 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -195,7 +195,7 @@ std/core/(&) |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| | _char_ | ::= | ``'`` (_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | +| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | | | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | | _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | |   | | | | @@ -263,12 +263,15 @@ std/core/(&) | | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_| | | _cont_ | ::= | ``x80..xBF`` | | |   | | | | -| _utf8unsafe_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | -| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A`` up to right-to-left override ``u202F``) | -| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xAB``) | (left-to-right isolate (``u2066`` up to activate symmetric swapping ``u206B``) | +| _utf8unsafe_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | +| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | +| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| {.grammar .lex} +[utf8unsafe]: https://arxiv.org/pdf/2111.00169.pdf +[bidi]: https://en.wikipedia.org/wiki/Bidirectional_text + ## Layout {#sec-layout} [Haskell]: http://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3 diff --git a/src/Syntax/Lexer.x b/src/Syntax/Lexer.x index 9e634f91a..c7055dda1 100644 --- a/src/Syntax/Lexer.x +++ b/src/Syntax/Lexer.x @@ -66,7 +66,7 @@ $charesc = [nrt\\\'\"] -- " | \xF4 [\x80-\x8F] $cont $cont @utf8unsafe = \xE2 \x80 [\x8E-\x8F\xAA-\xAE] - | \xE2 \x81 [\xA6-\xAB] + | \xE2 \x81 [\xA6-\xA9] @utf8 = @utf8valid From c970240536a758b2b0d57dcaf113d76efe7e047e Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 10:34:36 -0800 Subject: [PATCH 011/233] small fixes to grammar --- doc/spec/spec.kk.md | 130 ++++++++++++++++++++++---------------------- 1 file changed, 65 insertions(+), 65 deletions(-) diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index e7a75f150..491b673f9 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -13,21 +13,21 @@ We define the grammar and lexical syntax of the language using standard BNF notation where non-terminals are generated by alternative patterns: |~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _nonterm_ | ::= | _pattern_~1~ []{.bar} _pattern_~2~ | | +| _nonterm_ | ::= | _pattern_~1~ &bar; _pattern_~2~ | | {.grammar} In the patterns, we use the following notations: |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| | `terminal` | | A terminal symbol (in ascii) | -| ``x0B`` | | A character with hexadecimal code 0B | -| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``0x61..0x66``) | +| ``x1B`` | | A character with hexadecimal code 1B | +| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``x61..x66``) | |   | | | | ( _pattern_ ) | | Grouping | | [ _pattern_ ] | | Optional occurrence of _pattern_ | | { _pattern_ } | | Zero or more occurrences of _pattern_ | | { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | -| _pattern_~1~ []{.bar} _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | +| _pattern_~1~ &bar; _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | |   | | | | _pattern_~<! _diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | | _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | @@ -39,7 +39,7 @@ In the patterns, we use the following notations: --> Care must be taken to distinguish meta-syntax such as - []{.bar} and ) + &bar; and ) from concrete terminal symbols as ``|`` and ``)``. In the specification the order of the productions is not important and at each point the _longest matching lexeme_ is preferred. For example, even though @@ -81,12 +81,12 @@ comments and directives. ### Lexical tokens { test } | ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| -| _lex_ | ::= | _lexeme_ []{.bar} _whitespace_ | | -| _lexeme_   | ::= | _conid_ []{.bar} _qconid_ | | -| | &bar; | _varid_ []{.bar} _qvarid_ | | -| | &bar; | _op_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _wildcard_ | | -| | &bar; | _integer_ []{.bar} _float_ []{.bar} _string_ []{.bar} _char_ | | -| | &bar; | _reserved_ []{.bar} _opreserved_ | | +| _lex_ | ::= | _lexeme_ &bar; _whitespace_ | | +| _lexeme_   | ::= | _conid_ &bar; _qconid_ | | +| | &bar; | _varid_ &bar; _qvarid_ | | +| | &bar; | _op_ &bar; _opid_ &bar; _qopid_ &bar; _wildcard_ | | +| | &bar; | _integer_ &bar; _float_ &bar; _string_ &bar; _char_ | | +| | &bar; | _reserved_ &bar; _opreserved_ | | | | &bar; | _special_ | | {.grammar .lex} @@ -96,7 +96,7 @@ grammar will draw it's lexemes from the _lex_ production. ### Identifiers |~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~| -| _anyid_ | ::= | _varid_ []{.bar} _qvarid_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _conid_ []{.bar} _qconid_ | | +| _anyid_ | ::= | _varid_ &bar; _qvarid_ &bar; _opid_ &bar; _qopid_ &bar; _conid_ &bar; _qconid_ | | |   | | | | | _qconid_ | ::= | _modulepath_ _conid_ | | | _qvarid_ | ::= | _modulepath_ _lowerid_ | | @@ -111,26 +111,26 @@ grammar will draw it's lexemes from the _lex_ production. | _typevarid_ | ::= | _letter_ [_digit_]{.many} | | |   | | | | | _idtail_ | ::= | [_idchar_]{.many} [_idfinal_]{.opt} | | -| _idchar_ | ::= | _letter_ []{.bar} _digit_ []{.bar} ``_`` []{.bar} ``-`` | | +| _idchar_ | ::= | _letter_ &bar; _digit_ &bar; ``_`` &bar; ``-`` | | | _idfinal_ | ::= | [``'``]{.many} | | |   | | | | -| _reserved_ | ::= | `infix` []{.bar} `infixr` []{.bar} `infixl` | | -| | &bar; | ``module`` []{.bar} `import` []{.bar} `as` | | -| | &bar; | ``pub`` []{.bar} `abstract` | | -| | &bar; | `type` []{.bar} `struct` []{.bar} `alias` []{.bar} `effect` []{.bar} `con` | | -| | &bar; | `forall` []{.bar} `exists` []{.bar} `some` | | -| | &bar; | `fun` []{.bar} `fn` []{.bar} `val` []{.bar} `var` []{.bar} `extern` | | -| | &bar; | `if` []{.bar} `then` []{.bar} `else` []{.bar} `elif` | | -| | &bar; | `match` []{.bar} `return` []{.bar} `with` []{.bar} `in` | | -| | &bar; | `handle` []{.bar} `handler` []{.bar} `mask` | | -| | &bar; | `ctl` []{.bar} `final` []{.bar} `raw` | | -| | &bar; | `override` []{.bar} `named` | | -| | &bar; | `interface` []{.bar} `break` []{.bar} `continue` []{.bar} `unsafe` | (future reserved words) | +| _reserved_ | ::= | `infix` &bar; `infixr` &bar; `infixl` | | +| | &bar; | ``module`` &bar; `import` &bar; `as` | | +| | &bar; | ``pub`` &bar; `abstract` | | +| | &bar; | `type` &bar; `struct` &bar; `alias` &bar; `effect` &bar; `con` | | +| | &bar; | `forall` &bar; `exists` &bar; `some` | | +| | &bar; | `fun` &bar; `fn` &bar; `val` &bar; `var` &bar; `extern` | | +| | &bar; | `if` &bar; `then` &bar; `else` &bar; `elif` | | +| | &bar; | `match` &bar; `return` &bar; `with` &bar; `in` | | +| | &bar; | `handle` &bar; `handler` &bar; `mask` | | +| | &bar; | `ctl` &bar; `final` &bar; `raw` | | +| | &bar; | `override` &bar; `named` | | +| | &bar; | `interface` &bar; `break` &bar; `continue` &bar; `unsafe` | (future reserved words) | |   | | | | -| _specialid_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} `behind` | | -| | &bar; | `linear` []{.bar} `value` []{.bar} `reference` | | -| | &bar; | `inline` []{.bar} `noinline` []{.bar} `initially` []{.bar} `finally` | | -| | &bar; | `js` []{.bar} `c` []{.bar} `cs` []{.bar} `file` | | +| _specialid_ | ::= | `co` &bar; `rec` &bar; `open` &bar; `extend` &bar; `behind` | | +| | &bar; | `linear` &bar; `value` &bar; `reference` | | +| | &bar; | `inline` &bar; `noinline` &bar; `initially` &bar; `finally` | | +| | &bar; | `js` &bar; `c` &bar; `cs` &bar; `file` | | {.grammar .lex} Identifiers always start with a letter, may contain underscores and @@ -175,19 +175,19 @@ std/core/(&) | _qopid_ | ::= | _modulepath_ _opid_ | | | _opid_ | ::= | `(` _symbols_ `)` | | |   | | | | -| _op_ | ::= | _symbols_~<!\ _opreserved_[]{.bar}_optype_>~ []{.bar} ``\(&bar;&bar;\)`` | | +| _op_ | ::= | _symbols_~<!\ _opreserved_&bar;_optype_>~ &bar; ``\(&bar;&bar;\)`` | | |   | | | | -| _symbols_ | ::= | _symbol_ [_symbol_]{.many}[]{.bar} ``/`` | | -| _symbol_ | ::= | `$` []{.bar} `%` []{.bar} ``&`` []{.bar} `*` []{.bar} `+` | | -| | &bar; | ``~`` []{.bar} ``!`` []{.bar} ``\`` []{.bar} `^` []{.bar} ``#`` | | -| | &bar; | ``=`` []{.bar} ``.`` []{.bar} ``:`` []{.bar} `-` []{.bar} `?` | | +| _symbols_ | ::= | _symbol_ [_symbol_]{.many}&bar; ``/`` | | +| _symbol_ | ::= | `$` &bar; `%` &bar; ``&`` &bar; `*` &bar; `+` | | +| | &bar; | ``~`` &bar; ``!`` &bar; ``\`` &bar; `^` &bar; ``#`` | | +| | &bar; | ``=`` &bar; ``.`` &bar; ``:`` &bar; `-` &bar; `?` | | | | &bar; | _anglebar_ | | -| _anglebar_ | ::= | ``<`` []{.bar} ``>`` []{.bar} ``\(&bar;\)`` | | +| _anglebar_ | ::= | ``<`` &bar; ``>`` &bar; ``\(&bar;\)`` | | |   | | | | -| _opreserved_ | ::= | `=` []{.bar} `.` []{.bar} ``:`` []{.bar} `->` | | +| _opreserved_ | ::= | `=` &bar; `.` &bar; ``:`` &bar; `->` | | | _optype_ | ::= | _anglebar_ _anglebar_ [_anglebar_]{.many} | | |   | | | | -| _special_ | ::= | `{` []{.bar} `}` []{.bar} `(` []{.bar} `)` []{.bar} `[` []{.bar} `]` []{.bar} ``\(&bar;\)`` []{.bar} `;` []{.bar} `,` | | +| _special_ | ::= | `{` &bar; `}` &bar; `(` &bar; `)` &bar; `[` &bar; `]` &bar; ``\(&bar;\)`` &bar; `;` &bar; `,` | | |   | | | | {.grammar .lex} @@ -199,18 +199,18 @@ std/core/(&) | | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | | _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | |   | | | | -| _escape_ | ::= | ``\`` ( _charesc_ []{.bar} _hexesc_ ) | | -| _charesc_ | ::= | `n` []{.bar} `r` []{.bar} `t` []{.bar} ``\`` []{.bar} ``"`` []{.bar} ``'`` | | -| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ []{.bar} `u` [_hexdigit_]{.manyx}~4~ []{.bar} ``U`` [_hexdigit_]{.manyx}~6~ | | +| _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | +| _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | +| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ &bar; `u` [_hexdigit_]{.manyx}~4~ &bar; ``U`` [_hexdigit_]{.manyx}~6~ | | |   | | | | -| _float_ | ::= | [``-``]{.opt} (decfloat []{.bar} hexfloat) | | -| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} []{.bar} _decexp_) | | +| _float_ | ::= | [``-``]{.opt} (decfloat &bar; hexfloat) | | +| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} &bar; _decexp_) | | | _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | -| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} []{.bar} _hexexp_) | | +| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} &bar; _hexexp_) | | | _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | | _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | |   | | | | -| _integer_ | ::= | [``-``]{.opt} (_decimal_ []{.bar} _hexadecimal_) | | +| _integer_ | ::= | [``-``]{.opt} (_decimal_ &bar; _hexadecimal_) | | | _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | | _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | | _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | @@ -220,30 +220,30 @@ std/core/(&) ### White space |~~~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _whitespace_ | ::= | _white_ [_white_]{.many} []{.bar} _newline_ | | +| _whitespace_ | ::= | _white_ [_white_]{.many} &bar; _newline_ | | | _white_ | ::= | _space_ | | -| | &bar; | _linecomment_ []{.bar} _blockcomment_ | | +| | &bar; | _linecomment_ &bar; _blockcomment_ | | | | &bar; | _linedirective_ | | |   | | | | | _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | | _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | -| _linechar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ | | +| _linechar_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | [_any_]{.many}~/*[]{.bar}*/)\ [_any_]{.many}>~ | | +| _blockpart_ | ::= | [_any_]{.many}~/*&bar;*/)\ [_any_]{.many}>~ | | {.grammar .lex} ### Character classes |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _letter_ | ::= | _upper_ []{.bar} _lower_ | | +| _letter_ | ::= | _upper_ &bar; _lower_ | | | _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | | _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | | _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | | _posdigit_ | ::= | ``1..9`` | | -| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | +| _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | |   | | | | -| _any_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | (in comments and raw strings) | +| _any_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | | _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | |   | | | | | _space_ | ::= | ``x20`` | (a space) | @@ -477,7 +477,7 @@ ignored. | _module_~[_lex_]{.opt}~ | ::= | [_moduledecl_]{.opt} _modulebody_ | | |   | | | | | _moduledecl_ | ::= | _semis_ `module` _moduleid_ | | -| _moduleid_ | ::= | _qvarid_ []{.bar} _varid_ | | +| _moduleid_ | ::= | _qvarid_ &bar; _varid_ | | |   | | | | | _modulebody_ | ::= | `{` _semis_ _declarations_ `}` _semis_ | | | | &bar; | _semis_ _declarations_ | | @@ -515,8 +515,8 @@ ignored. | _typedecl_ | ::= | _typemod_ `type` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_typebody_]{.opt} | | | | &bar; | _structmod_ `struct` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_conparams_]{.opt} | | |   | | | | -| _typemod_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} _structmod_ | | -| _structmod_ | ::= | `value` []{.bar} `reference` | | +| _typemod_ | ::= | `co` &bar; `rec` &bar; `open` &bar; `extend` &bar; _structmod_ | | +| _structmod_ | ::= | `value` &bar; `reference` | | |   | | | | | _typeid_ | ::= | _varid_ &bar; ``[]`` &bar; `(` [`,`]{.many} `)` &bar; `<` `>` &bar; `<` [&bar;]{.koka; .code} `>` | | |   | | | | @@ -534,7 +534,7 @@ ignored. | ~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~| | _puredecl_ | ::= | [_inlinemod_]{.opt} `val` _valdecl_ | | | | &bar; | [_inlinemod_]{.opt} `fun` _fundecl_ | | -| _inlinemod_ | ::= | `inline` []{.bar} `noinline` | | +| _inlinemod_ | ::= | `inline` &bar; `noinline` | | |   | | | | | _valdecl_ | ::= | _binder_ `=` _blockexpr_ | | | _binder_ | ::= | _identifier_ [``:`` _type_]{.opt} | | @@ -551,14 +551,14 @@ ignored. | _pparameters_ | ::= | `(` [_pparameter_ [`,` _pparameter_]{.many}]{.opt} `)` | (pattern matching parameters) | | _pparameter_ | ::= | [_borrow_]{.opt} _pattern_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | |   | | | | -| _paramid_ | ::= | _identifier_ []{.bar} _wildcard_ | | +| _paramid_ | ::= | _identifier_ &bar; _wildcard_ | | | _borrow_ | ::= | ``^`` | (not allowed from _conparams_) | |   | | | | -| _qidentifier_ | ::= | _qvarid_ []{.bar} _qidop_ []{.bar} _identifier_ | | -| _identifier_ | ::= | _varid_ []{.bar} _idop_ | | +| _qidentifier_ | ::= | _qvarid_ &bar; _qidop_ &bar; _identifier_ | | +| _identifier_ | ::= | _varid_ &bar; _idop_ | | |   | | | | | _qoperator_ | ::= | _op_ | | -| _qconstructor_ | ::= | _conid_ []{.bar} _qconid_ | | +| _qconstructor_ | ::= | _conid_ &bar; _qconid_ | | {.grammar .parse} ### Statements @@ -620,15 +620,15 @@ in an expressions. | ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| | _opexpr_ | ::= | _prefixexpr_ [_qoperator_ _prefixexpr_]{.many} | | -| _prefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _appexpr_ | | +| _prefixexpr_ | ::= | [``!`` &bar; ``~``]{.many} _appexpr_ | | | _appexpr_ | ::= | _appexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | | | &bar; | _appexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | -| | &bar; | _appexpr_ (_fnexpr_ []{.bar} _block_) | (trailing lambda expression) | +| | &bar; | _appexpr_ (_fnexpr_ &bar; _block_) | (trailing lambda expression) | | | &bar; | _appexpr_ `.` _atom_ | | | | &bar; | _atom_ | | |   | | | | | _ntlexpr_ | ::= | _ntlprefixexpr_ [_qoperator_ _ntlprefixexpr_]{.many} | (non trailing lambda expression) | -| _ntlprefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _ntlappexpr_ | | +| _ntlprefixexpr_ | ::= | [``!`` &bar; ``~``]{.many} _ntlappexpr_ | | | _ntlappexpr_ | ::= | _ntlappexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | | | &bar; | _ntlappexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | | | &bar; | _ntlappexpr_ `.` _atom_ | | @@ -651,7 +651,7 @@ in an expressions. | | &bar; | `(` _annexprs_ `)` | (tuple expression) | | | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | |   | | | | -| _literal_ | ::= | _natural_ []{.bar} _float_ []{.bar} _char_ []{.bar} _string_ | | +| _literal_ | ::= | _natural_ &bar; _float_ &bar; _char_ &bar; _string_ | | | _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | |   | | | | | _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | @@ -690,7 +690,7 @@ in an expressions. |   | | | | | _opdecls_ | ::= | `{` _semis_ [_opdecl_ _semi_]{.many} `}` | | | _opdecl_ | ::= | [ _pub_]{.opt} `val` _identifier_ [_typeparams_]{.opt} ``:`` _tatom_ | | -| | &bar; | [ _pub_]{.opt} (`fun` []{.bar} `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | +| | &bar; | [ _pub_]{.opt} (`fun` &bar; `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | {.grammar .parse} ### Handler Expressions @@ -751,7 +751,7 @@ in an expressions. |   | | | | | _typeapp_ | ::= | _typecon_ [`<` _anntype_ [`,` _anntype_]{.many} `>`]{.opt} | | |   | | | | -| _typecon_ | ::= | _varid_ []{.bar} _qvarid_ | | +| _typecon_ | ::= | _varid_ &bar; _qvarid_ | | | | &bar; | _wildcard_ | | | | &bar; | `(` `,` [`,`]{.many} `)` | (tuple constructor) | | | &bar; | `[` `]` | (list constructor) | From fb91b1c2a9510f1e782d52bb8e84b0397723b333 Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 10:39:02 -0800 Subject: [PATCH 012/233] fix bars in docs --- doc/spec/book.kk.md | 11 ++++++----- doc/spec/styles/book.css | 3 --- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/doc/spec/book.kk.md b/doc/spec/book.kk.md index bbbf41971..e08693545 100644 --- a/doc/spec/book.kk.md +++ b/doc/spec/book.kk.md @@ -25,11 +25,12 @@ body { .colored } -~bar : before='|' -~many : before='{ ' after=' }' -~manyn : before='{ ' after=' }~_n_~' -~manyx : before='{ ' after=' }' -~opt : before='[ ' after=' ]' +bar: [|]{padding:0ex 0.25ex} + +~many : before='{ '; after=' }' +~manyn : before='{ '; after=' }~_n_~' +~manyx : before='{ '; after=' }' +~opt : before='[ '; after=' ]' [koka-logo]: images/koka-logo-filled.png { max-height: 120px; padding:1rem 1rem 1rem 1.5rem; } diff --git a/doc/spec/styles/book.css b/doc/spec/styles/book.css index d5a50afa9..d8d20c1b6 100644 --- a/doc/spec/styles/book.css +++ b/doc/spec/styles/book.css @@ -78,9 +78,6 @@ table.grammar { padding: 0pt; } -.grammar .bar { - padding: 0ex 0.5ex; -} .grammar td:nth-child(2) { font-style: normal; From a426f7c6ccb1f94613bf3340f724627616d546dc Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 11:12:32 -0800 Subject: [PATCH 013/233] update grammar --- doc/spec/book.kk.md | 5 +++- doc/spec/spec.kk.md | 69 ++++++++++++++++++++------------------------- 2 files changed, 35 insertions(+), 39 deletions(-) diff --git a/doc/spec/book.kk.md b/doc/spec/book.kk.md index e08693545..e62c6d611 100644 --- a/doc/spec/book.kk.md +++ b/doc/spec/book.kk.md @@ -31,7 +31,10 @@ bar: [|]{padding:0ex 0.25ex} ~manyn : before='{ '; after=' }~_n_~' ~manyx : before='{ '; after=' }' ~opt : before='[ '; after=' ]' - +~diff { + before: '~[~' +} [koka-logo]: images/koka-logo-filled.png { max-height: 120px; padding:1rem 1rem 1rem 1.5rem; } diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 491b673f9..9b2ce04d7 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -27,25 +27,19 @@ In the patterns, we use the following notations: | [ _pattern_ ] | | Optional occurrence of _pattern_ | | { _pattern_ } | | Zero or more occurrences of _pattern_ | | { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | -| _pattern_~1~ &bar; _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | +| _pattern_~1~ &bar; _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | |   | | | -| _pattern_~<! _diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | +| _pattern_[_diff_]{.diff} | | Difference: elements generated by _pattern_ except those in _diff_ | | _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | {.grammar} - -Care must be taken to distinguish meta-syntax such as - &bar; and ) +Care must be taken to distinguish meta-syntax such as &bar; and ) from concrete terminal symbols as ``|`` and ``)``. In the specification the order of the productions is not important and at each point the _longest matching lexeme_ is preferred. For example, even though `fun` is a reserved word, the word `functional` is considered a -single identifier. A _prefix_ or _postfix_ pattern is included -when considering a longest match. +single identifier. {.grammar} ### Source code @@ -80,14 +74,14 @@ comments and directives. ### Lexical tokens { test } -| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| +| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| | _lex_ | ::= | _lexeme_ &bar; _whitespace_ | | | _lexeme_   | ::= | _conid_ &bar; _qconid_ | | | | &bar; | _varid_ &bar; _qvarid_ | | -| | &bar; | _op_ &bar; _opid_ &bar; _qopid_ &bar; _wildcard_ | | -| | &bar; | _integer_ &bar; _float_ &bar; _string_ &bar; _char_ | | +| | &bar; | _op_ &bar; _opid_ &bar; _qopid_ &bar; _wildcard_ | | +| | &bar; | _integer_ &bar; _float_ &bar; _string_ &bar; _char_ | | | | &bar; | _reserved_ &bar; _opreserved_ | | -| | &bar; | _special_ | | +| | &bar; | _special_ | | {.grammar .lex} The main program consists of _whitespace_ or _lexeme_'s. The context-free @@ -103,7 +97,7 @@ grammar will draw it's lexemes from the _lex_ production. | _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | |   | | | | | _conid_ | ::= | _upperid_ | | -| _varid_ | ::= | _lowerid_~<! _reserved_>~ | | +| _varid_ | ::= | _lowerid_[_reserved_]{.diff} | | |   | | | | | _lowerid_ | ::= | _lower_ _idtail_ | | | _upperid_ | ::= | _upper_ _idtail_ | | @@ -175,7 +169,7 @@ std/core/(&) | _qopid_ | ::= | _modulepath_ _opid_ | | | _opid_ | ::= | `(` _symbols_ `)` | | |   | | | | -| _op_ | ::= | _symbols_~<!\ _opreserved_&bar;_optype_>~ &bar; ``\(&bar;&bar;\)`` | | +| _op_ | ::= | _symbols_[_opreserved_ &bar; _optype_]{.diff} &bar; ``\(&bar;&bar;\)`` | | |   | | | | | _symbols_ | ::= | _symbol_ [_symbol_]{.many}&bar; ``/`` | | | _symbol_ | ::= | `$` &bar; `%` &bar; ``&`` &bar; `*` &bar; `+` | | @@ -194,10 +188,10 @@ std/core/(&) ### Literals |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` (_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_~~ &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | +| _char_ | ::= | ``'`` (_graphic_[``'`` &bar; ``\``]{.diff} &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | +| _string_ | ::= | ``"`` [_graphic_[``"`` &bar; ``\``]{.diff} &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | | | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | -| _rawstring_~_n_~ | ::= | [_any_]{.many}~~ | | +| _rawstring_~_n_~ | ::= | [_any_]{.many}[[_any_]{.many} ``"`` [``#``]{.manyn} [_any_]{.many}]{.diff} | | |   | | | | | _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | | _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | @@ -207,12 +201,12 @@ std/core/(&) | _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} &bar; _decexp_) | | | _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | | _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} &bar; _hexexp_) | | -| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | -| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | +| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | +| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | |   | | | | | _integer_ | ::= | [``-``]{.opt} (_decimal_ &bar; _hexadecimal_) | | | _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | -| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | +| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | | _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | | _hexdigits_ | ::= | _hexdigit_ [_hexdigit_]{.many} [``_`` _hexdigit_ [_hexdigit_]{.many}]{.many} | | {.grammar .lex} @@ -230,7 +224,7 @@ std/core/(&) | _linechar_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | [_any_]{.many}~/*&bar;*/)\ [_any_]{.many}>~ | | +| _blockpart_ | ::= | [_any_]{.many}[[_any_]{.many}\ (/*&bar;*/)\ [_any_]{.many}]{.diff} | | {.grammar .lex} ### Character classes @@ -241,7 +235,7 @@ std/core/(&) | _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | | _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | | _posdigit_ | ::= | ``1..9`` | | -| _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | +| _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | |   | | | | | _any_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | | _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | @@ -252,20 +246,19 @@ std/core/(&) | _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | | _graphic_ | ::= | ``x21..x7E`` | (a visible character) | |   | | | | -| _utf8_ | ::= | _utf8valid_~~ | | -| _utf8valid_| ::= | (``xC2..xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | | -| | &bar; | (``xE1..xEC``) _cont_ _cont_ | | -| | &bar; | ``xED`` (``x80..x9F``) _cont_ | | -| | &bar; | (``xEE..xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_| | -| | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_| | -| _cont_ | ::= | ``x80..xBF`` | | -|   | | | | -| _utf8unsafe_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | -| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | -| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| +| _utf8_ | ::= | _utf8valid_[_bidi_]{.diff} | | +| _utf8valid_| ::= | (``xC2..xDF``) _cont_ | | +| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | | +| | &bar; | (``xE1..xEC``) _cont_ _cont_ | | +| | &bar; | ``xED`` (``x80..x9F``) _cont_ | | +| | &bar; | (``xEE..xEF``) _cont_ _cont_ | | +| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | | +| | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | +| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | | +| _cont_ | ::= | ``x80..xBF`` | | +| _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | +| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | +| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| {.grammar .lex} From da8e56f2a782ba51e46633e3a38ac85b2a02663d Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 16:21:25 -0800 Subject: [PATCH 014/233] search system C library first before using vcpkg and conan --- src/Compiler/Compile.hs | 45 +++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 153e276bb..7869e77fb 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -1345,30 +1345,20 @@ copyCLibrary term flags cc eimport = case Core.eimportLookup (buildType flags) "library" eimport of Nothing -> return [] Just clib - -> do mb <- do -- use conan? - mbConan <- case lookup "conan" eimport of - Just pkg | not (null (conan flags)) - -> conanCLibrary term flags cc eimport clib pkg - _ -> return (Left []) - case mbConan of + -> do mb <- do mbSearch <- search [] [ searchCLibrary flags cc clib (ccompLibDirs flags) + , case lookup "conan" eimport of + Just pkg | not (null (conan flags)) + -> conanCLibrary term flags cc eimport clib pkg + _ -> return (Left []) + , case lookup "vcpkg" eimport of + Just pkg + -> vcpkgCLibrary term flags cc eimport clib pkg + _ -> return (Left []) + ] + case mbSearch of Right res -> return (Just res) - Left conanWarns - -> do -- use vcpkg? (we prefer this as conan is not working well on windows across cl, clang, and mingw) - mbVcpkg <- case lookup "vcpkg" eimport of - Just pkg - -> vcpkgCLibrary term flags cc eimport clib pkg - _ -> return (Left []) - case mbVcpkg of - Right res -> return (Just res) - Left vcpkgWarns - -> do -- try to find the library and headers directly - mbSearch <- searchCLibrary flags cc clib (ccompLibDirs flags) - case mbSearch of - Right res -> return (Just res) - Left searchWarns - -> do let warns = intersperse (text "or") (vcpkgWarns ++ conanWarns ++ searchWarns) - termWarning term flags (vcat warns) - return Nothing + Left warn -> do termWarning term flags warn + return Nothing case mb of Just (libPath,includes) -> do termPhaseDoc term (color (colorInterpreter (colorScheme flags)) (text "library:") <+> @@ -1383,7 +1373,14 @@ copyCLibrary term flags cc eimport text " hint: provide \"--cclibdir\" as an option, or use \"syslib\" in an extern import?" raiseIO ("unable to find C library " ++ clib ++ "\nlibrary search paths: " ++ show (ccompLibDirs flags)) - + where + search :: [Doc] -> [IO (Either [Doc] (FilePath,[FilePath]))] -> IO (Either Doc (FilePath,[FilePath])) + search warns [] = return (Left (vcat (intersperse (text "or") warns))) + search warns (io:ios) + = do mbRes <- io + case mbRes of + Right res -> return (Right res) + Left warns' -> search (warns ++ warns') ios searchCLibrary :: Flags -> CC -> FilePath -> [FilePath] -> IO (Either [Doc] (FilePath {-libPath-},[FilePath] {-include paths-})) searchCLibrary flags cc clib searchPaths From 4cc56ba604cb088ffa725715d19f01e55b9ab83c Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 16:54:57 -0800 Subject: [PATCH 015/233] update doc --- lib/std/num/ddouble.kk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/std/num/ddouble.kk b/lib/std/num/ddouble.kk index b3b3143df..77bd16ef7 100644 --- a/lib/std/num/ddouble.kk +++ b/lib/std/num/ddouble.kk @@ -6,7 +6,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -/* Double-double 128-bit floating point numbers. +/* 128-bit double-double floating point numbers. The `:ddouble` type implements [double double][ddwiki] 128-bit floating point numbers as a pair of IEEE `:float64` values. This extends the precision to 31 decimal digits From 04ef2da7c8b35ce2bfacc8fda2d56ed6d35ad732 Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 17:14:42 -0800 Subject: [PATCH 016/233] add bigint division test --- test/lib/bigint3.kk | 8 ++++++++ test/lib/bigint3.kk.out | 1 + 2 files changed, 9 insertions(+) create mode 100644 test/lib/bigint3.kk create mode 100644 test/lib/bigint3.kk.out diff --git a/test/lib/bigint3.kk b/test/lib/bigint3.kk new file mode 100644 index 000000000..c85950bac --- /dev/null +++ b/test/lib/bigint3.kk @@ -0,0 +1,8 @@ +// test for TAOCP Vol 2 bigint division bug (1st & 2nd edition), +// see: + +noinline fun muldiv( x : int, y : int, z : int ) : int + (x*y)/z + +pub fun main() + muldiv(18446744069414584318, 4294967296, 18446744069414584319).println // 4294967295 diff --git a/test/lib/bigint3.kk.out b/test/lib/bigint3.kk.out new file mode 100644 index 000000000..b7bf491bc --- /dev/null +++ b/test/lib/bigint3.kk.out @@ -0,0 +1 @@ +4294967295 \ No newline at end of file From dfe233efc09d14013226518e8b803e11d89e1ee3 Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 18 Feb 2022 17:21:13 -0800 Subject: [PATCH 017/233] add comment 'sum' function about precision --- lib/std/num/float64.kk | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 673f8c9b7..97e383288 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -566,6 +566,8 @@ extern prim-parse-float64( s : string ) : float64 // to minimize rounding errors. This // is more precise as Kahan summation and about as fast.\ // `[1.0e3,1.0e97,1.0e3,-1.0e97].sum == 2000.0`\ +// while\ +// `[1.0e3,1.0e97,1.0e3,-1.0e97].foldl(0.0,(+)) == 0.0` (!)\ // A. Neumaier, _Rundungsfehleranalyse einiger Verfahren zur Summation endlicher Summen_. // Math. Mechanik, 54:39--51, 1974. pub fun sum( xs : list ) : float64 From 9b8bb230090a9d91f6887631b1a7ff0ce82c966d Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 21 Feb 2022 21:48:34 -0800 Subject: [PATCH 018/233] update lexical grammar for unicode --- doc/spec/koka.bib | 10 ++++++ doc/spec/spec.kk.md | 78 +++++++++++++++++++++++++-------------------- 2 files changed, 53 insertions(+), 35 deletions(-) diff --git a/doc/spec/koka.bib b/doc/spec/koka.bib index fd4bf412a..f36d01855 100644 --- a/doc/spec/koka.bib +++ b/doc/spec/koka.bib @@ -1,3 +1,13 @@ +@article{Boucher:trojan, + title = {Trojan {Source}: {Invisible} {Vulnerabilities}}, + author = {Nicholas Boucher and Ross Anderson}, + year = {2021}, + journal = {Preprint}, + eprint = {2111.00169}, + archivePrefix = {arXiv}, + primaryClass = {cs.CR}, + url = {https://arxiv.org/abs/2111.00169} +} @techreport{Lorenzen:reuse-tr, author = {Lorenzen, Anton and Leijen, Daan}, diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 9b2ce04d7..8e95a22a8 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -19,9 +19,9 @@ notation where non-terminals are generated by alternative patterns: In the patterns, we use the following notations: |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| `terminal` | | A terminal symbol (in ascii) | +| `terminal` | | A terminal symbol (in ASCII) | | ``x1B`` | | A character with hexadecimal code 1B | -| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``x61..x66``) | +| ``A..F`` | | The characters from "A" to "F" (using ASCII, i.e. ``x61..x66``) | |   | | | | ( _pattern_ ) | | Grouping | | [ _pattern_ ] | | Optional occurrence of _pattern_ | @@ -44,22 +44,12 @@ single identifier. ### Source code -Source code consists of a sequence of 8-bit characters. Valid characters in -actual program code consists strictly of ASCII characters which range from 0 -to 127 and can be encoded in 7-bits. Only comments, string literals, and -character literals are allowed to contain extended 8-bit characters. - -### Encoding - -A program source is assumed to be UTF-8 encoded which allows comments, -string literals, and character literals to contain (encoded) unicode -characters. Moreover, the grammar is designed such that a lexical -analyzer and parser can directly work on source files without doing UTF-8 -decoding or unicode category identification. To further facilitate the -processing of UTF-8 encoded files the lexical analyzer ignores an initial -byte-order mark that some UTF-8 encoders insert. In particular, any -program source is allowed to start with three byte-order mark bytes -``0xEF``, ``0xBB``, and ``0xBF``, which are ignored. +Source code consists of a sequence of unicode characters. Valid characters in +actual program code consist strictly of ASCII characters which range from 0 to 127. +Only comments, string literals, and character literals are allowed to +contain extended unicode characters. The grammar is designed such that a lexical +analyzer and parser can directly work on UTF-8 encoded source files without +actually doing UTF-8 decoding or unicode category identification. ## Lexical grammar @@ -188,10 +178,9 @@ std/core/(&) ### Literals |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` (_graphic_[``'`` &bar; ``\``]{.diff} &bar; _space_ &bar; _utf8_ &bar; _escape_) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_[``"`` &bar; ``\``]{.diff} &bar; _space_ &bar; _utf8_ &bar; _escape_]{.many} ``"`` | | -| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawstring_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | -| _rawstring_~_n_~ | ::= | [_any_]{.many}[[_any_]{.many} ``"`` [``#``]{.manyn} [_any_]{.many}]{.diff} | | +| _char_ | ::= | ``'`` (_graphic_[``'`` &bar; ``\``]{.diff} &bar; _space_ &bar; _unicode_ &bar; _escape_) ``'`` | | +| _string_ | ::= | ``"`` [_graphic_[``"`` &bar; ``\``]{.diff} &bar; _space_ &bar; _unicode_ &bar; _escape_]{.many} ``"`` | | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` [_any_]{.many}[[_any_]{.many} ``"`` [``#``]{.manyn} [_any_]{.many}]{.diff} ``"`` [``#``]{.manyn} | (raw strings, n >= 0) | |   | | | | | _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | | _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | @@ -221,7 +210,7 @@ std/core/(&) |   | | | | | _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | | _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | -| _linechar_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ | | +| _linechar_ | ::= | _graphic_ &bar; _unicode_ &bar; _space_ &bar; _tab_ | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | | _blockpart_ | ::= | [_any_]{.many}[[_any_]{.many}\ (/*&bar;*/)\ [_any_]{.many}]{.diff} | | @@ -237,7 +226,7 @@ std/core/(&) | _posdigit_ | ::= | ``1..9`` | | | _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | |   | | | | -| _any_ | ::= | _graphic_ &bar; _utf8_ &bar; _space_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | +| _any_ | ::= | _graphic_ &bar; _unicode_ &bar; _space_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | | _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | |   | | | | | _space_ | ::= | ``x20`` | (a space) | @@ -246,16 +235,35 @@ std/core/(&) | _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | | _graphic_ | ::= | ``x21..x7E`` | (a visible character) | |   | | | | -| _utf8_ | ::= | _utf8valid_[_bidi_]{.diff} | | -| _utf8valid_| ::= | (``xC2..xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | | -| | &bar; | (``xE1..xEC``) _cont_ _cont_ | | -| | &bar; | ``xED`` (``x80..x9F``) _cont_ | | -| | &bar; | (``xEE..xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | | +| _unicode_ | ::= | _extended_[_control1_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | +| _extended_ | ::= | ``x80..x10FFFF`` | | +| _control1_ | ::= | ``x80..x9F`` | | +| _surrogate_| ::= | ``xD800..xDFFF`` | | +| _bidi_ | ::= | ``x200E`` &bar; ``x200F`` &bar; ``x202A..x202E`` &bar; ``x2066..x2069`` | (bi-directional text control) | +{.grammar .lex} + +Actual program code consists only of 7-bit ASCII characters while only comments +and literals can contain extended unicode characters. For security +[@Boucher:trojan], some character ranges are excluded: the C0 and C1 +[control codes](https://en.wikipedia.org/wiki/C0_and_C1_control_codes) (except for space, +tab, carriage return, and line feeds), surrogate characters, and bi-directional +text control characters. + +A lexical analyzer can actually directly process UTF-8 encoded input as +a sequence of bytes. This is used for example in the [Flex][FlexLexer] implementation. +In particular, we only need to adapt the _unicode_ definition: + +|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _unicode_ | ::= | _extended_[_control1_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | +| _extended_ | ::= | (``xC2..xDF``) _cont_ | | +| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | +| | &bar; | (``xE1..xEF``) _cont_ _cont_ | | +| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | (exclude overlong encodings) | | | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | | +| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | | _cont_ | ::= | ``x80..xBF`` | | +| _control1_ | ::= | ``xC2`` (``x80..x9F``) | | +| _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | | _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | | | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | | | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| @@ -447,7 +455,7 @@ grammar elements as ended by semicolons instead of separated by semicolons which is more difficult to specify for a LALR(1) grammar. The layout can be implemented as a separate transformation on the lexical token -stream (see the [Haskell][HaskellLayout] implementation in the Koka compiler), +stream (see the 50 line [Haskell][HaskellLayout] implementation in the Koka compiler), or directly as part of the lexer (see the [Flex][FlexLexer] implementation) ### Implementation { #sec:lex-implementation } @@ -782,5 +790,5 @@ as _the_ specification of the grammar and this document should always be in agreement with that implementation. [BisonGrammar]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/parser.y -[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.lex -[HaskellLayout]: https://github.com/koka-lang/koka/blob/dev/src/Syntax/Layout.hs#L178 \ No newline at end of file +[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.l +[HaskellLayout]: https://github.com/koka-lang/koka/blob/dev/src/Syntax/Layout.hs#L181 \ No newline at end of file From aca5a815f3f0e4d1da9a46a08eea50bccf681a4f Mon Sep 17 00:00:00 2001 From: Daan Date: Tue, 22 Feb 2022 09:46:08 -0800 Subject: [PATCH 019/233] update lexical grammar for unicode --- doc/spec/spec.kk.md | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 8e95a22a8..ed58371cc 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -69,7 +69,7 @@ comments and directives. | _lexeme_   | ::= | _conid_ &bar; _qconid_ | | | | &bar; | _varid_ &bar; _qvarid_ | | | | &bar; | _op_ &bar; _opid_ &bar; _qopid_ &bar; _wildcard_ | | -| | &bar; | _integer_ &bar; _float_ &bar; _string_ &bar; _char_ | | +| | &bar; | _integer_ &bar; _float_ &bar; _stringlit_ &bar; _charlit_ | | | | &bar; | _reserved_ &bar; _opreserved_ | | | | &bar; | _special_ | | {.grammar .lex} @@ -178,9 +178,9 @@ std/core/(&) ### Literals |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` (_graphic_[``'`` &bar; ``\``]{.diff} &bar; _space_ &bar; _unicode_ &bar; _escape_) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_[``"`` &bar; ``\``]{.diff} &bar; _space_ &bar; _unicode_ &bar; _escape_]{.many} ``"`` | | -| | &bar; | ``r`` [``#``]{.manyn} ``"`` [_any_]{.many}[[_any_]{.many} ``"`` [``#``]{.manyn} [_any_]{.many}]{.diff} ``"`` [``#``]{.manyn} | (raw strings, n >= 0) | +| _charlit_ | ::= | ``'`` (_char_[``'`` &bar; ``\``]{.diff} &bar; _escape_) ``'`` | | +| _stringlit_ | ::= | ``"`` [_char_[``"`` &bar; ``\``]{.diff} &bar; _escape_]{.many} ``"`` | | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` [_anychar_]{.many}[[_anychar_]{.many} ``"`` [``#``]{.manyn} [_anychar_]{.many}]{.diff} ``"`` [``#``]{.manyn} | (raw strings, n >= 0) | |   | | | | | _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | | _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | @@ -210,10 +210,9 @@ std/core/(&) |   | | | | | _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | | _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | -| _linechar_ | ::= | _graphic_ &bar; _unicode_ &bar; _space_ &bar; _tab_ | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | [_any_]{.many}[[_any_]{.many}\ (/*&bar;*/)\ [_any_]{.many}]{.diff} | | +| _blockpart_ | ::= | [_anychar_]{.many}[[_anychar_]{.many}\ (/*&bar;*/)\ [_anychar_]{.many}]{.diff} | | {.grammar .lex} ### Character classes @@ -226,18 +225,18 @@ std/core/(&) | _posdigit_ | ::= | ``1..9`` | | | _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | |   | | | | -| _any_ | ::= | _graphic_ &bar; _unicode_ &bar; _space_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | -| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | -|   | | | | | _space_ | ::= | ``x20`` | (a space) | | _tab_ | ::= | ``x09`` | (a tab (``\t``)) | | _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | | _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | -| _graphic_ | ::= | ``x21..x7E`` | (a visible character) | |   | | | | -| _unicode_ | ::= | _extended_[_control1_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | -| _extended_ | ::= | ``x80..x10FFFF`` | | -| _control1_ | ::= | ``x80..x9F`` | | +| _anychar_ | ::= | _linechar_ &bar; _newline_ | (in comments and raw strings) | +| _linechar_ | ::= | _char_ &bar; _tab_ | (in line comments and directives) | +| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | +|   | | | | +| _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | (includes _space_) | +| _unicode_ | ::= | ``x00..x10FFFF`` | | +| _control_ | ::= | ``x00..x1F`` &bar; ``x7F..9F`` | (C0, C1, and DEL) | | _surrogate_| ::= | ``xD800..xDFFF`` | | | _bidi_ | ::= | ``x200E`` &bar; ``x200F`` &bar; ``x202A..x202E`` &bar; ``x2066..x2069`` | (bi-directional text control) | {.grammar .lex} @@ -248,22 +247,24 @@ and literals can contain extended unicode characters. For security [control codes](https://en.wikipedia.org/wiki/C0_and_C1_control_codes) (except for space, tab, carriage return, and line feeds), surrogate characters, and bi-directional text control characters. - -A lexical analyzer can actually directly process UTF-8 encoded input as +The lexical grammar is designed in such a way tha +a lexical analyzer can directly process UTF-8 encoded input as a sequence of bytes. This is used for example in the [Flex][FlexLexer] implementation. -In particular, we only need to adapt the _unicode_ definition: +In particular, we only need to adapt the _graphic_ definition: |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _unicode_ | ::= | _extended_[_control1_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | -| _extended_ | ::= | (``xC2..xDF``) _cont_ | | +| _graphic_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | +| _unicode_ | ::= | ``x00..x7F`` | (ASCII) | +| | &bar; | (``xC2..xDF``) _cont_ | | | | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | | | &bar; | (``xE1..xEF``) _cont_ _cont_ | | | | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | (exclude overlong encodings) | | | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | | | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | | _cont_ | ::= | ``x80..xBF`` | | -| _control1_ | ::= | ``xC2`` (``x80..x9F``) | | | _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | +| _control_ | ::= | ``x00..x1F`` &bar; ``x7F`` | +| | &bar; | ``xC2`` (``x80..x9F``) | | | _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | | | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | | | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| @@ -652,7 +653,7 @@ in an expressions. | | &bar; | `(` _annexprs_ `)` | (tuple expression) | | | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | |   | | | | -| _literal_ | ::= | _natural_ &bar; _float_ &bar; _char_ &bar; _string_ | | +| _literal_ | ::= | _natural_ &bar; _float_ &bar; _charlit_ &bar; _stringlit_ | | | _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | |   | | | | | _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | From 21450baf0cad0cf215893ee48f5f021fac5a643d Mon Sep 17 00:00:00 2001 From: Daan Date: Tue, 22 Feb 2022 10:15:36 -0800 Subject: [PATCH 020/233] update lexical grammar for unicode --- doc/spec/spec.kk.md | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index ed58371cc..196edf0b3 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -180,7 +180,8 @@ std/core/(&) |~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| | _charlit_ | ::= | ``'`` (_char_[``'`` &bar; ``\``]{.diff} &bar; _escape_) ``'`` | | | _stringlit_ | ::= | ``"`` [_char_[``"`` &bar; ``\``]{.diff} &bar; _escape_]{.many} ``"`` | | -| | &bar; | ``r`` [``#``]{.manyn} ``"`` [_anychar_]{.many}[[_anychar_]{.many} ``"`` [``#``]{.manyn} [_anychar_]{.many}]{.diff} ``"`` [``#``]{.manyn} | (raw strings, n >= 0) | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawchars_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | +| _rawchars_~_n_~ | ::= | [_anychar_]{.many}[[_anychar_]{.many} ``"`` [``#``]{.manyn} [_anychar_]{.many}]{.diff} | | |   | | | | | _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | | _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | @@ -208,8 +209,8 @@ std/core/(&) | | &bar; | _linecomment_ &bar; _blockcomment_ | | | | &bar; | _linedirective_ | | |   | | | | -| _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | -| _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | +| _linecomment_ | ::= | ``//`` [_char_ &bar; _tab_]{.many} | | +| _linedirective_ | ::= | _newline_ ``#`` [_char_ &bar; _tab_]{.many} | | |   | | | | | _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | | _blockpart_ | ::= | [_anychar_]{.many}[[_anychar_]{.many}\ (/*&bar;*/)\ [_anychar_]{.many}]{.diff} | | @@ -225,18 +226,17 @@ std/core/(&) | _posdigit_ | ::= | ``1..9`` | | | _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | |   | | | | +| _anychar_ | ::= | _char_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | +| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | +|   | | | | | _space_ | ::= | ``x20`` | (a space) | | _tab_ | ::= | ``x09`` | (a tab (``\t``)) | | _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | | _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | |   | | | | -| _anychar_ | ::= | _linechar_ &bar; _newline_ | (in comments and raw strings) | -| _linechar_ | ::= | _char_ &bar; _tab_ | (in line comments and directives) | -| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | -|   | | | | | _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | (includes _space_) | | _unicode_ | ::= | ``x00..x10FFFF`` | | -| _control_ | ::= | ``x00..x1F`` &bar; ``x7F..9F`` | (C0, C1, and DEL) | +| _control_ | ::= | ``x00..x1F`` &bar; ``x7F`` &bar; ``x80..9F`` | (C0, DEL, and C1) | | _surrogate_| ::= | ``xD800..xDFFF`` | | | _bidi_ | ::= | ``x200E`` &bar; ``x200F`` &bar; ``x202A..x202E`` &bar; ``x2066..x2069`` | (bi-directional text control) | {.grammar .lex} @@ -250,10 +250,10 @@ text control characters. The lexical grammar is designed in such a way tha a lexical analyzer can directly process UTF-8 encoded input as a sequence of bytes. This is used for example in the [Flex][FlexLexer] implementation. -In particular, we only need to adapt the _graphic_ definition: +In particular, we only need to adapt the _char_ definition: |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _graphic_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | +| _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | | _unicode_ | ::= | ``x00..x7F`` | (ASCII) | | | &bar; | (``xC2..xDF``) _cont_ | | | | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | @@ -263,7 +263,8 @@ In particular, we only need to adapt the _graphic_ definition: | | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | | _cont_ | ::= | ``x80..xBF`` | | | _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | -| _control_ | ::= | ``x00..x1F`` &bar; ``x7F`` | +| _control_ | ::= | ``x00..x1F`` | +| | &bar; | ``x7F`` | | | | &bar; | ``xC2`` (``x80..x9F``) | | | _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | | | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | From a72e6c09154f21a392604ddde35b49de3c3c3c0a Mon Sep 17 00:00:00 2001 From: Daan Date: Wed, 23 Feb 2022 11:48:39 -0800 Subject: [PATCH 021/233] update docs --- doc/spec/spec.kk.md | 50 ++++++++++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 196edf0b3..0e314d815 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -242,34 +242,38 @@ std/core/(&) {.grammar .lex} Actual program code consists only of 7-bit ASCII characters while only comments -and literals can contain extended unicode characters. For security +and literals can contain extended unicode characters. As such, +a lexical analyzer can directly process UTF-8 encoded input as +a sequence of bytes without needing UTF-8 decoding or unicode character +classification[^fn-utf8]. +For security [@Boucher:trojan], some character ranges are excluded: the C0 and C1 [control codes](https://en.wikipedia.org/wiki/C0_and_C1_control_codes) (except for space, tab, carriage return, and line feeds), surrogate characters, and bi-directional text control characters. -The lexical grammar is designed in such a way tha -a lexical analyzer can directly process UTF-8 encoded input as -a sequence of bytes. This is used for example in the [Flex][FlexLexer] implementation. -In particular, we only need to adapt the _char_ definition: -|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | -| _unicode_ | ::= | ``x00..x7F`` | (ASCII) | -| | &bar; | (``xC2..xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | -| | &bar; | (``xE1..xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | (exclude overlong encodings) | -| | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | -| _cont_ | ::= | ``x80..xBF`` | | -| _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | -| _control_ | ::= | ``x00..x1F`` | -| | &bar; | ``x7F`` | | -| | &bar; | ``xC2`` (``x80..x9F``) | | -| _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | -| | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | -| | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| -{.grammar .lex} + +[^fn-utf8]: This is used for example in the [Flex][FlexLexer] implementation. + In particular, we only need to adapt the _char_ definition: + + |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| + | _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | + | _unicode_ | ::= | ``x00..x7F`` | (ASCII) | + | | &bar; | (``xC2..xDF``) _cont_ | | + | | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | + | | &bar; | (``xE1..xEF``) _cont_ _cont_ | | + | | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | (exclude overlong encodings) | + | | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | + | | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | + | _cont_ | ::= | ``x80..xBF`` | | + | _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | + | _control_ | ::= | ``x00..x1F`` | + | | &bar; | ``x7F`` | | + | | &bar; | ``xC2`` (``x80..x9F``) | | + | _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | + | | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | + | | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| + {.grammar .lex} [utf8unsafe]: https://arxiv.org/pdf/2111.00169.pdf From 5966afec64c6340de2d40a3a7166ed840cbc378e Mon Sep 17 00:00:00 2001 From: Daan Date: Tue, 15 Mar 2022 09:47:08 -0700 Subject: [PATCH 022/233] update docs for brew and update stack on M1 --- doc/spec/install.mdk | 11 ++++++++++- readme.md | 14 ++++++-------- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/doc/spec/install.mdk b/doc/spec/install.mdk index 01d6421e8..a4f2f5b62 100644 --- a/doc/spec/install.mdk +++ b/doc/spec/install.mdk @@ -15,6 +15,15 @@ [logo-debian]: images/logo-debian.svg { height: 1em; vertical-align: -0.4ex; } [logo-freebsd]: images/logo-freebsd.svg { height: 0.8em; vertical-align: -0.2ex; } +[Homebrew]: https://brew.sh + +On macOS (x64, M1), you can install and upgrade &koka; using Homebrew: + +&acopy; +{.copy; data-value:"brew install koka"} + + \(**brew install koka**\) + On Windows (x64), open a ``cmd`` prompt and use: &acopy; @@ -22,7 +31,7 @@ On Windows (x64), open a ``cmd`` prompt and use: \(**curl -sSL -o %tmp%\install-koka.bat https://github.com/koka-lang/koka/releases/latest/download/install.bat && %tmp%\install-koka.bat**\) -On Linux (x64, arm64), macOS (x64, M1), and FreeBSD (x64), you can install &koka; using: +On Linux (x64, arm64) and FreeBSD (x64) (and macOS), you can install &koka; using: &acopy; {.copy; data-value:"curl -sSL https://github.com/koka-lang/koka/releases/latest/download/install.sh | sh"} diff --git a/readme.md b/readme.md index e107fa9ad..d6f835cad 100644 --- a/readme.md +++ b/readme.md @@ -136,9 +136,8 @@ without problems on most common platforms, e.g. Windows (including WSL), macOS, Unix. The following programs are required to build Koka: * [Stack](https://docs.haskellstack.org/) to run the Haskell compiler. - Use `curl -sSL https://get.haskellstack.org/ | sh` - on Unix and macOS x64, or the binary [installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe) on Windows. - On macOS M1, use `brew install haskell-stack --head` (and see the [build notes](#build-notes) below). + Use `brew install haskell-stack` on macOS, `curl -sSL https://get.haskellstack.org/ | sh` on Unix, + or the binary [installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe) on Windows. * Optional: [vcpkg] to be able to link easily with C libraries. Use `brew install vcpkg` on macOS. On other systems use the vcpkg [install][vcpkg] instructions (Koka can find vcpkg automatically if installed to `~/vcpkg`). @@ -159,7 +158,7 @@ $ stack exec koka You can also use `stack build --fast` to build a debug version of the compiler. Use `stack test --fast` to run the test-suite. -(See the [build notes](#build-notes) below for building macOS M1, or if you have issues when running- or installing `stack`). +(See the [build notes](#build-notes) below if you have issues when running- or installing `stack`). ## Create an Install Bundle @@ -328,9 +327,8 @@ The main development branches are: ## Building on macOS M1 -Currently (Dec 2021) you need to use `brew install haskell-stack --head` -to get the latest `2.7.4` version of stack. (Have patience as the cabal -install step takes about 20 min). Moreover, you need to add the `brew` +You need at least `stack` version 2.7.4. +Furthermore, you may need to add the `brew` installed LLVM to your path afterwards, or otherwise stack cannot find the LLVM tools. Add the following to your `~/.zshrc` script and open an fresh prompt: @@ -506,4 +504,4 @@ Also as MSR-TR-2021-5, Mar, 2021. [pdf](https://www.microsoft.com/en-us/research/publication/generalized-evidence-passing-for-effect-handlers/) 10. Anton Lorenzen and Daan Leijen. “ Reference Counting with Frame-Limited Reuse” Microsoft Research -technical report MSR-TR-2021-30, Nov 2021. [pdf](https://www.microsoft.com/en-us/research/publication/reference-counting-with-frame-limited-reuse-extended-version/) +technical report MSR-TR-2021-30, Nov 2021, (updated Mar 2022, v2). [pdf](https://www.microsoft.com/en-us/research/publication/reference-counting-with-frame-limited-reuse-extended-version/) From 6d105afa68c7939447d415dcc6c3d9b82d770090 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 16 Mar 2022 20:48:09 -0700 Subject: [PATCH 023/233] clean up time and timers to use durations --- kklib/include/kklib.h | 5 +- kklib/include/kklib/os.h | 29 +++-- kklib/include/kklib/platform.h | 8 +- kklib/include/kklib/process.h | 12 +- kklib/src/init.c | 14 ++- kklib/src/process.c | 64 ---------- kklib/src/time.c | 208 +++++++++++++++++++-------------- lib/std/time/chrono-inline.c | 7 +- lib/std/time/timer-inline.c | 7 +- 9 files changed, 167 insertions(+), 187 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 0dc53d5d9..1d2f204bb 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -342,7 +342,7 @@ typedef int64_t kk_asecs_t; typedef struct kk_duration_s { kk_secs_t seconds; kk_asecs_t attoseconds; // always >= 0 -} kk_duration_t; +} kk_duration_t; // Box any is used when yielding @@ -395,7 +395,7 @@ typedef struct kk_context_s { struct kk_random_ctx_s* srandom_ctx; // strong random using chacha20, initialized on demand kk_ssize_t argc; // command line argument count const char** argv; // command line arguments - kk_timer_t process_start; // time at start of the process + kk_duration_t process_start; // time at start of the process int64_t timer_freq; // high precision timer frequency kk_duration_t timer_prev; // last requested timer time kk_duration_t timer_delta; // applied timer delta (to ensure monotonicity) @@ -442,6 +442,7 @@ kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ); kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ); kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); + /*-------------------------------------------------------------------------------------- Allocation --------------------------------------------------------------------------------------*/ diff --git a/kklib/include/kklib/os.h b/kklib/include/kklib/os.h index 4f555bb71..e949d37af 100644 --- a/kklib/include/kklib/os.h +++ b/kklib/include/kklib/os.h @@ -35,12 +35,6 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, kk_decl_export int kk_os_run_command(kk_string_t cmd, kk_string_t* output, kk_context_t* ctx); kk_decl_export int kk_os_run_system(kk_string_t cmd, kk_context_t* ctx); -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* atto_secs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); - -kk_decl_export kk_secs_t kk_time_unix_now(kk_asecs_t* atto_secs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx); - kk_decl_export kk_string_t kk_compiler_version(kk_context_t* ctx); kk_decl_export kk_string_t kk_cc_name(kk_context_t* ctx); kk_decl_export kk_string_t kk_os_name(kk_context_t* ctx); @@ -48,6 +42,27 @@ kk_decl_export kk_string_t kk_cpu_arch(kk_context_t* ctx); kk_decl_export int kk_cpu_count(kk_context_t* ctx); kk_decl_export bool kk_cpu_is_little_endian(kk_context_t* ctx); -kk_decl_export bool kk_os_set_stack_size( kk_ssize_t stack_size ); +kk_decl_export bool kk_os_set_stack_size(kk_ssize_t stack_size); + + +/*-------------------------------------------------------------------------------------- + Time and timers +--------------------------------------------------------------------------------------*/ + +kk_decl_export bool kk_duration_is_zero(kk_duration_t x); +kk_decl_export bool kk_duration_is_gt(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_sub(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_add(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_neg(kk_duration_t x); +kk_decl_export kk_duration_t kk_duration_from_secs(int64_t secs); +kk_decl_export kk_duration_t kk_duration_from_nsecs(int64_t nsecs); + + +kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx); +kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); + +kk_decl_export kk_duration_t kk_time_unix_now(kk_context_t* ctx); +kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx); + #endif // include guard diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 5f1590fab..b0b761569 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -336,10 +336,10 @@ typedef unsigned kk_uintx_t; #define KK_INTX_MAX INT_MAX #define KK_INTX_MIN INT_MIN #define KK_UINTX_MAX UINT_MAX -#define PRIdIX "%d" -#define PRIuUX "%u" -#define PRIxUX "%x" -#define PRIXUX "%X" +#define PRIdIX "d" +#define PRIuUX "u" +#define PRIxUX "x" +#define PRIXUX "X" #else #error "platform cannot be determined to have natural 16, 32, or 64 bit registers" #endif diff --git a/kklib/include/kklib/process.h b/kklib/include/kklib/process.h index ff51ae2cd..6f9df2894 100644 --- a/kklib/include/kklib/process.h +++ b/kklib/include/kklib/process.h @@ -9,15 +9,9 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ - -typedef int64_t kk_msecs_t; -typedef int64_t kk_usecs_t; -typedef kk_usecs_t kk_timer_t; - -kk_timer_t kk_timer_start(void); -kk_usecs_t kk_timer_end(kk_timer_t start); -void kk_process_info(kk_msecs_t* utime, kk_msecs_t* stime, - size_t* peak_rss, size_t* page_faults, size_t* page_reclaim, size_t* peak_commit); +typedef int64_t kk_msecs_t; +void kk_process_info(kk_msecs_t* utime, kk_msecs_t* stime, + size_t* peak_rss, size_t* page_faults, size_t* page_reclaim, size_t* peak_commit); #endif // include guard diff --git a/kklib/src/init.c b/kklib/src/init.c index 7dd417f0f..9e70d632a 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -7,6 +7,8 @@ ---------------------------------------------------------------------------*/ //#define _CRT_SECURE_NO_WARNINGS #include "kklib.h" +#include "kklib/os.h" // kk_timer_now + #include #include #ifdef WIN32 @@ -232,6 +234,7 @@ void kk_free_context(void) { /*-------------------------------------------------------------------------------------------------- Called from main --------------------------------------------------------------------------------------------------*/ +static bool kk_showtime; // false kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { kk_context_t* ctx = kk_get_context(); @@ -241,7 +244,8 @@ kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { for (i = 1; i < argc; i++) { // argv[0] is the program name const char* arg = argv[i]; if (strcmp(arg, "--kktime")==0) { - ctx->process_start = kk_timer_start(); + kk_showtime = true; + ctx->process_start = kk_timer_ticks(ctx); } else { break; @@ -258,8 +262,8 @@ kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { } kk_decl_export void kk_main_end(kk_context_t* ctx) { - if (ctx->process_start != 0) { // started with --kktime option - kk_usecs_t wall_time = kk_timer_end(ctx->process_start); + if (kk_showtime) { // started with --kktime option + kk_duration_t wall_time = kk_duration_sub(kk_timer_ticks(ctx), ctx->process_start); kk_msecs_t user_time; kk_msecs_t sys_time; size_t peak_rss; @@ -267,8 +271,8 @@ kk_decl_export void kk_main_end(kk_context_t* ctx) { size_t page_reclaim; size_t peak_commit; kk_process_info(&user_time, &sys_time, &peak_rss, &page_faults, &page_reclaim, &peak_commit); - kk_info_message("elapsed: %ld.%03lds, user: %ld.%03lds, sys: %ld.%03lds, rss: %lu%s\n", - (long)(wall_time/1000000), (long)((wall_time%1000000)/1000), + kk_info_message("elapsed: %" PRId64 ".%03lds, user: %ld.%03lds, sys : %ld.%03lds, rss : %lu%s\n", + wall_time.seconds, (long)(wall_time.attoseconds / (KK_I64(1000000) * KK_I64(1000000000))), user_time/1000, user_time%1000, sys_time/1000, sys_time%1000, (peak_rss > 10*1024*1024 ? peak_rss/(1024*1024) : peak_rss/1024), (peak_rss > 10*1024*1024 ? "mb" : "kb") ); diff --git a/kklib/src/process.c b/kklib/src/process.c index 01c1285fd..4f47d2990 100644 --- a/kklib/src/process.c +++ b/kklib/src/process.c @@ -7,70 +7,6 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" -#define KK_USEC_PER_SEC 1000000 - -// ---------------------------------------------------------------- -// Basic timer for convenience; use micro-seconds to avoid doubles -// (2^63-1) us ~= 292471 years -// ---------------------------------------------------------------- -#ifdef WIN32 -#include -static kk_usecs_t kk_to_usecs(LARGE_INTEGER t) { - static LARGE_INTEGER mfreq; // = 0 - if (mfreq.QuadPart == 0) { - QueryPerformanceFrequency(&mfreq); - //mfreq.QuadPart = f.QuadPart/I64(1000000); - if (mfreq.QuadPart == 0) mfreq.QuadPart = 1000; - } - // calculate in parts to avoid overflow - int64_t secs = t.QuadPart / mfreq.QuadPart; - int64_t frac = t.QuadPart % mfreq.QuadPart; - kk_usecs_t u = secs*KK_USEC_PER_SEC + ((frac*KK_USEC_PER_SEC)/mfreq.QuadPart); - return u; -} - -static kk_usecs_t kk_timer_now(void) { - LARGE_INTEGER t; - QueryPerformanceCounter(&t); - return kk_to_usecs(t); -} -#else -#include -#ifdef CLOCK_REALTIME -static kk_usecs_t kk_timer_now(void) { - struct timespec t; - clock_gettime(CLOCK_REALTIME, &t); - return ((kk_usecs_t)t.tv_sec * KK_USEC_PER_SEC) + ((kk_usecs_t)t.tv_nsec/1000); -} -#else -// low resolution timer -static kk_usecs_t kk_timer_now(void) { - int64_t t = (int64_t)clock(); - // calculate in parts to avoid overflow - int64_t secs = t / (int64_t)CLOCKS_PER_SEC; - int64_t frac = t % (int64_t)CLOCKS_PER_SEC; - return (secs*KK_USEC_PER_SEC + ((frac*KK_USEC_PER_SEC)/CLOCKS_PER_SEC); -} -#endif -#endif - -static kk_usecs_t kk_timer_diff; - -kk_timer_t kk_timer_start(void) { - if (kk_timer_diff == 0) { - kk_timer_t t0 = kk_timer_now(); - kk_timer_diff = kk_timer_now() - t0; - if (kk_timer_diff==0) kk_timer_diff = 1; - } - return kk_timer_now(); -} - -kk_usecs_t kk_timer_end(kk_timer_t start) { - kk_usecs_t end = kk_timer_now(); - return (end - start - kk_timer_diff); -} - - // -------------------------------------------------------- // Basic process statistics // -------------------------------------------------------- diff --git a/kklib/src/time.c b/kklib/src/time.c index bbfda5eaa..ae46b428e 100644 --- a/kklib/src/time.c +++ b/kklib/src/time.c @@ -7,20 +7,81 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" + +/*-------------------------------------------------------------------------------------- + Durations +--------------------------------------------------------------------------------------*/ + +bool kk_duration_is_zero(kk_duration_t x) { + return (x.seconds == 0 && x.attoseconds == 0); +} + +bool kk_duration_is_gt(kk_duration_t x, kk_duration_t y) { + kk_assert(x.attoseconds >= 0 && y.attoseconds >= 0); + return (x.seconds > y.seconds || (x.seconds == y.seconds && x.attoseconds > y.attoseconds)); +} + + #define KK_NSECS_PER_SEC KK_I64(1000000000) #define KK_ASECS_PER_NSEC KK_I64(1000000000) +#define KK_ASECS_PER_MSEC (1000000 * KK_ASECS_PER_NSEC) #define KK_ASECS_PER_SEC (KK_NSECS_PER_SEC * KK_ASECS_PER_NSEC) +kk_duration_t kk_duration_from_secs(int64_t secs) { + kk_duration_t d; + d.seconds = secs; + d.attoseconds = 0; + return d; +} + +kk_duration_t kk_duration_zero(void) { + return kk_duration_from_secs(0); +} + +kk_duration_t kk_duration_norm(kk_duration_t x) { + while (x.attoseconds < 0) { + x.seconds--; + x.attoseconds += KK_ASECS_PER_SEC; + } + while (x.attoseconds >= KK_ASECS_PER_SEC) { + x.seconds++; + x.attoseconds -= KK_ASECS_PER_SEC; + } + return x; +} + +kk_duration_t kk_duration_neg(kk_duration_t x) { + kk_duration_t d; + d.seconds = -x.seconds; + d.attoseconds = -x.attoseconds; + return kk_duration_norm(d); +} + +kk_duration_t kk_duration_add(kk_duration_t x, kk_duration_t y) { + kk_duration_t z; + z.seconds = x.seconds + y.seconds; + z.attoseconds = x.attoseconds + y.attoseconds; + return kk_duration_norm(z); +} + +kk_duration_t kk_duration_sub(kk_duration_t x, kk_duration_t y) { + return kk_duration_add(x, kk_duration_neg(y)); +} + +kk_duration_t kk_duration_from_nsecs(int64_t nsecs) { + kk_duration_t d; + d.seconds = nsecs / KK_NSECS_PER_SEC; + d.attoseconds = (nsecs % KK_NSECS_PER_SEC) * KK_ASECS_PER_NSEC; + return kk_duration_norm(d); +} + /*-------------------------------------------------------------------------------------------------- Timer ticks --------------------------------------------------------------------------------------------------*/ -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* asecs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); // in atto seconds - #ifdef WIN32 #include -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { LARGE_INTEGER t; QueryPerformanceCounter(&t); if (ctx->timer_freq == 0) { @@ -31,13 +92,12 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { } kk_assert_internal(ctx->timer_freq != 0); // calculate in parts for precision - kk_secs_t secs = t.QuadPart / ctx->timer_freq; - int64_t frac = t.QuadPart % ctx->timer_freq; - if (asecs != NULL) { - int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; - *asecs = frac * resolution; - } - return secs; + kk_duration_t d; + d.seconds = t.QuadPart / ctx->timer_freq; + int64_t frac = t.QuadPart % ctx->timer_freq; + int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; + d.attoseconds = frac * resolution; + return d; } #else @@ -50,7 +110,7 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { #endif // high res timer -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { if (ctx->timer_freq == 0) { struct timespec tres = { 0, 0 }; clock_getres(CLOCK_MONOTONIC, &tres); @@ -63,65 +123,51 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { } struct timespec t; clock_gettime(CLOCK_MONOTONIC, &t); - if (asecs != NULL) { - *asecs = t.tv_nsec * KK_ASECS_PER_NSEC; - } - return t.tv_sec; + kk_duration_t d; + d.seconds = t.tv_sec; + d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; + return d; } #else // low resolution timer #pragma message("using low-res timer on this platform") -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { if (ctx->timer_freq == 0) { ctx->timer_freq = (int64_t)CLOCKS_PER_SEC; if (ctx->timer_freq <= 0) { ctx->timer_freq = 1000; } } int64_t t = (int64_t)clock(); // calculate in parts for precision - int64_t secs = t / ctx->timer_freq; - int64_t frac = t % ctx->timer_freq; - if (asecs != NULL) { - int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; - *asecs = frac * resolution; - } - return secs; + kk_duration_t d; + d.seconds = t / ctx->timer_freq; + const int64_t frac = t % ctx->timer_freq; + const int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; + d.attoseconds = frac * resolution; + return d; } #endif #endif -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* atto_secs, kk_context_t* ctx) { - kk_asecs_t asecs; - kk_secs_t secs = kk_timer_ticks_prim(&asecs, ctx); +kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx) { + const kk_duration_t d = kk_timer_ticks_prim(ctx); // init previous and delta - if (ctx->timer_prev.seconds == 0 && ctx->timer_prev.attoseconds == 0) { - ctx->timer_prev.seconds = secs; - ctx->timer_prev.attoseconds = asecs; - ctx->timer_delta.seconds = secs; - ctx->timer_delta.attoseconds = asecs; + if (kk_duration_is_zero(ctx->timer_prev)) { + ctx->timer_prev = d; + ctx->timer_delta = d; } // check monotonicity - if (ctx->timer_prev.seconds > secs || (ctx->timer_prev.seconds == secs && ctx->timer_prev.attoseconds >= asecs)) { + if (kk_duration_is_gt( ctx->timer_prev, d)) { // ouch, clock ran backward; add 1 nano second and adjust the delta - ctx->timer_delta.seconds = ctx->timer_prev.seconds - secs; - ctx->timer_delta.attoseconds = ctx->timer_prev.attoseconds - asecs - KK_NSECS_PER_SEC; // can be negative + ctx->timer_delta = kk_duration_sub(kk_duration_sub(ctx->timer_prev, d), kk_duration_from_nsecs(1)); } // save time in previous and adjust with the delta - ctx->timer_prev.seconds = secs; - ctx->timer_prev.attoseconds = asecs; - secs -= ctx->timer_delta.seconds; - asecs -= ctx->timer_delta.attoseconds; - if (asecs < 0) { - secs -= 1; - asecs += KK_ASECS_PER_SEC; - } - kk_assert_internal(secs >= 0 && asecs >= 0); - if (atto_secs != NULL) *atto_secs = asecs; - return secs; + ctx->timer_prev = d; + return kk_duration_sub(d, ctx->timer_delta); } kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx) { - kk_timer_ticks_prim(NULL, ctx); // initialize + kk_timer_ticks_prim(ctx); // initialize kk_assert_internal(ctx->timer_freq != 0); return (KK_ASECS_PER_SEC / ctx->timer_freq); } @@ -133,31 +179,29 @@ kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx) { #ifdef WIN32 #define KK_100NSECS_PER_SEC KK_I64(10000000) #define KK_UNIX_EPOCH KK_I64(11644473600) // seconds since 1601-01-01 UTC to 1970-01-01 (Unix epoch) -static kk_secs_t kk_time_unix_now_prim(kk_secs_t* atto_secs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { FILETIME ft; GetSystemTimeAsFileTime(&ft); LARGE_INTEGER ti; ti.LowPart = ft.dwLowDateTime; ti.HighPart = (LONG)ft.dwHighDateTime; int64_t t = ti.QuadPart; // t is the time in 100 nano seconds intervals since 1601-01-01 UTC. - int64_t secs = (t / KK_100NSECS_PER_SEC) - KK_UNIX_EPOCH; - int64_t fsecs = (t % KK_100NSECS_PER_SEC); + kk_duration_t d; + d.seconds = (t / KK_100NSECS_PER_SEC) - KK_UNIX_EPOCH; + d.attoseconds = (t % KK_100NSECS_PER_SEC) * 100 * KK_ASECS_PER_NSEC; if (ctx->time_freq == 0) { // initialize ctx->time_freq = KK_100NSECS_PER_SEC; } // done - if (atto_secs != NULL) { - *atto_secs = fsecs * 100 * KK_ASECS_PER_NSEC; - } - return secs; + return d; } #else #include #if defined(CLOCK_REALTIME) // high res time -static kk_secs_t kk_time_unix_now_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq==0) { struct timespec tres = { 0, 0 }; clock_getres(CLOCK_REALTIME, &tres); @@ -170,58 +214,46 @@ static kk_secs_t kk_time_unix_now_prim(kk_asecs_t* asecs, kk_context_t* ctx) { } struct timespec t; clock_gettime(CLOCK_REALTIME, &t); - if (asecs != NULL) { - *asecs = t.tv_nsec * KK_ASECS_PER_NSEC; - } - return t.tv_sec; + kk_duration_t d; + d.seconds = t.tv_sec; + d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; + return d; } #else // portable 1s resolution time -static kk_secs_t kk_time_unix_now_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq == 0) { ctx->time_freq = 1; // :-( } time_t t; time(&t); - if (asecs != NULL) { - *asecs = 0; - } - return t; + kk_duration_t d; + d.seconds = t; + d.attoseconds = 0; } #endif #endif -kk_decl_export kk_secs_t kk_time_unix_now(kk_asecs_t* atto_secs, kk_context_t* ctx) { - kk_asecs_t asecs; - kk_secs_t secs = kk_time_unix_now_prim(&asecs, ctx); - if ((ctx->time_unix_prev.seconds > secs || (ctx->time_unix_prev.seconds == secs && ctx->time_unix_prev.attoseconds >= asecs)) - // time is set backward! - && ((ctx->time_unix_prev.seconds - secs) <= 1 && - (ctx->time_unix_prev.seconds - secs)*KK_ASECS_PER_SEC + (ctx->time_unix_prev.attoseconds - asecs) <= KK_ASECS_PER_SEC) - // ((secs + frac + 1.0) > (ctx->time_unix_prev.seconds + ctx->time_unix_prev.second_fraction)) - // if it is less the 1 second we add a tiny increment as we assume it is due to leap second smearing - ) { +kk_decl_export kk_duration_t kk_time_unix_now(kk_context_t* ctx) { + kk_duration_t d = kk_time_unix_now_prim(ctx); + if (kk_duration_is_gt(ctx->time_unix_prev, d) + // time is set backward! + // if it is less the 1 second we add a tiny increment as we assume it is due to leap second smearing + && !kk_duration_is_gt(ctx->time_unix_prev, kk_duration_add(d,kk_duration_from_secs(1))) ) { // keep monotonic and allow to catch up - secs = ctx->time_unix_prev.seconds; - ctx->time_unix_prev.attoseconds += KK_ASECS_PER_NSEC; - asecs = ctx->time_unix_prev.attoseconds; - } - else { - // save previous time - ctx->time_unix_prev.seconds = secs; - ctx->time_unix_prev.attoseconds = asecs; + d = kk_duration_add(ctx->time_unix_prev, kk_duration_from_nsecs(1)); } - // done - if (atto_secs != NULL) { - *atto_secs = asecs; - } - return secs; + // save previous time + ctx->time_unix_prev = d; + return d; } kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx) { - kk_time_unix_now_prim(NULL, ctx); // initialize + if (ctx->time_freq == 0) { + kk_time_unix_now_prim(ctx); // initialize + } kk_assert_internal(ctx->time_freq != 0); return (KK_ASECS_PER_SEC / ctx->time_freq); } diff --git a/lib/std/time/chrono-inline.c b/lib/std/time/chrono-inline.c index 7deb61861..6b797b5f8 100644 --- a/lib/std/time/chrono-inline.c +++ b/lib/std/time/chrono-inline.c @@ -7,10 +7,9 @@ ---------------------------------------------------------------------------*/ static kk_std_core_types__tuple2_ kk_time_unix_now_tuple(kk_context_t* ctx) { - int64_t asecs; - int64_t isecs = kk_time_unix_now(&asecs,ctx); - double frac = (double)asecs * 1e-18; - double secs = (double)isecs; + kk_duration_t d = kk_time_unix_now(ctx); + double frac = (double)d.attoseconds * 1e-18; + double secs = (double)d.seconds; return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } diff --git a/lib/std/time/timer-inline.c b/lib/std/time/timer-inline.c index c9bc96ba9..da746bd46 100644 --- a/lib/std/time/timer-inline.c +++ b/lib/std/time/timer-inline.c @@ -7,10 +7,9 @@ ---------------------------------------------------------------------------*/ static kk_std_core_types__tuple2_ kk_timer_ticks_tuple(kk_context_t* ctx) { - int64_t asecs; - int64_t isecs = kk_timer_ticks(&asecs,ctx); - double frac = (double)asecs * 1e-18; - double secs = (double)isecs; + kk_duration_t d = kk_timer_ticks(ctx); + double frac = (double)d.attoseconds * 1e-18; + double secs = (double)d.seconds; return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } From 97095d88176061d276922ce97f0156b2825818d0 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 17 Mar 2022 13:47:45 -0700 Subject: [PATCH 024/233] rename float inline file --- lib/std/num/{float64-inline.h => float64-inline.c} | 0 lib/std/num/float64.kk | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename lib/std/num/{float64-inline.h => float64-inline.c} (100%) diff --git a/lib/std/num/float64-inline.h b/lib/std/num/float64-inline.c similarity index 100% rename from lib/std/num/float64-inline.h rename to lib/std/num/float64-inline.c diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 33b6543d1..a81ee1a09 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -18,7 +18,7 @@ import std/text/parse import std/num/int64 extern import - c file "float64-inline.h" + c file "float64-inline.c" js file "float64-inline.js" From 91f7acdaa423bbeb22b4fb3b8d8d6b0632b772d8 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 21 Apr 2022 21:03:34 -0700 Subject: [PATCH 025/233] extra tests: tak and sfib --- test/bench/koka/sfib-int.kk | 12 ++++++++++++ test/bench/koka/sfib.kk | 14 ++++++++++++++ test/bench/koka/tak-int.kk | 10 ++++++++++ test/bench/koka/tak.kk | 12 ++++++++++++ 4 files changed, 48 insertions(+) create mode 100644 test/bench/koka/sfib-int.kk create mode 100644 test/bench/koka/sfib.kk create mode 100644 test/bench/koka/tak-int.kk create mode 100644 test/bench/koka/tak.kk diff --git a/test/bench/koka/sfib-int.kk b/test/bench/koka/sfib-int.kk new file mode 100644 index 000000000..01d584b34 --- /dev/null +++ b/test/bench/koka/sfib-int.kk @@ -0,0 +1,12 @@ +module sfib-int + +fun sfibx(n : int, x1 : int, x2 : int) : div int + if n <= 0 + then x1 + else sfibx(n - 1, x2, (x1 + x2) / (x2 - x1)) + +fun sfib(n : int) + sfibx(n,2,8) + +pub fun main() + sfib(100000000).println \ No newline at end of file diff --git a/test/bench/koka/sfib.kk b/test/bench/koka/sfib.kk new file mode 100644 index 000000000..bc415abcb --- /dev/null +++ b/test/bench/koka/sfib.kk @@ -0,0 +1,14 @@ +module sfib + +import std/num/int32 + +fun sfibx(n : int32, x1 : int32, x2 : int32) : div int32 + if n <= zero + then x1 + else sfibx(n.dec, x2, (x1 + x2) / (x2 - x1)) + +fun sfib(n : int) + sfibx(n.int32,2.int32,8.int32).int + +pub fun main() + sfib(100000000).println \ No newline at end of file diff --git a/test/bench/koka/tak-int.kk b/test/bench/koka/tak-int.kk new file mode 100644 index 000000000..ec2ed3002 --- /dev/null +++ b/test/bench/koka/tak-int.kk @@ -0,0 +1,10 @@ +module tak + +pub fun tak(x : int, y : int, z : int ) : div int + if y < x + then tak( tak(x - 1, y, z), tak(y - 1, z, x), tak(z - 1, x, y) ) + else z + +pub fun main() + // tak(18,12,6).println + tak(36,24,14).println \ No newline at end of file diff --git a/test/bench/koka/tak.kk b/test/bench/koka/tak.kk new file mode 100644 index 000000000..6f908bedc --- /dev/null +++ b/test/bench/koka/tak.kk @@ -0,0 +1,12 @@ +module tak + +import std/num/int32 + +pub fun tak(x : int32, y : int32, z : int32 ) : div int32 + if y < x + then tak( tak(x - 1.int32, y, z), tak(y - 1.int32, z, x), tak(z - 1.int32, x, y) ) + else z + +pub fun main() + // tak(18,12,6).println + tak(36.int32,24.int32,14.int32).show.println \ No newline at end of file From d6e3ce114828bd068c4e869327a75c30540b547f Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 21 Apr 2022 21:52:18 -0700 Subject: [PATCH 026/233] add pythagorean triples benchmark --- lib/std/num/int32.kk | 23 +++++++++++++++++++++++ test/bench/koka/pyth-int.kk | 19 +++++++++++++++++++ test/bench/koka/pyth.kk | 21 +++++++++++++++++++++ 3 files changed, 63 insertions(+) create mode 100644 test/bench/koka/pyth-int.kk create mode 100644 test/bench/koka/pyth.kk diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 46bfd9c04..bbb731f27 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -349,3 +349,26 @@ pub fun fold-int32( start : int32, end : int32, init : a, f : (int32,a) -> e a ) val x = f(start,init) fold-int32(unsafe-decreasing(start.inc), end, x, f) + + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +pub fun for32( start: int32, end : int32, action : (int32) -> e () ) : e () + fun rep( i : int32 ) + if i <= end then + action(i) + rep(unsafe-decreasing(i.inc)) + rep(start) + + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +// If `action` returns `Just`, the iteration is stopped and the result returned +pub fun for-while32( start: int32, end : int32, action : (int32) -> e maybe ) : e maybe + fun rep( i : int32 ) + if i <= end then + match action(i) + Nothing -> rep(unsafe-decreasing(i.inc)) + Just(x) -> Just(x) + else Nothing + rep(start) \ No newline at end of file diff --git a/test/bench/koka/pyth-int.kk b/test/bench/koka/pyth-int.kk new file mode 100644 index 000000000..1e5f0354e --- /dev/null +++ b/test/bench/koka/pyth-int.kk @@ -0,0 +1,19 @@ +module pyth-int + +pub fun pyth(n : int ) : int + var count := 0 + for(1, n/3) fn(x) + val xx = x*x + for(x+1, n/2) fn(y) + val yy = y*y + for-while( y+1, n/2) fn(z) + val zz = z*z + if (xx+yy == zz) then count := count + 1 + if (xx+yy < zz) || (x+y+z > n) + then Just(()) + else Nothing + () + count + +pub fun main() + pyth(4000).println \ No newline at end of file diff --git a/test/bench/koka/pyth.kk b/test/bench/koka/pyth.kk new file mode 100644 index 000000000..10c060f63 --- /dev/null +++ b/test/bench/koka/pyth.kk @@ -0,0 +1,21 @@ +module pyth + +import std/num/int32 + +pub fun pyth(n : int32 ) : int + var count := 0 + for32(1.int32, n/3.int32) fn(x) + val xx = x*x + for32(x.inc, n/2.int32) fn(y) + val yy = y*y + for-while32( y.inc, n/2.int32) fn(z) + val zz = z*z + if (xx+yy == zz) then count := count + 1 + if (xx+yy < zz) || (x+y+z > n) + then Just(()) + else Nothing + () + count + +pub fun main() + pyth(4000.int32).println \ No newline at end of file From a158411f3baae6f2135910808e90d32f9c04ae90 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 21 Apr 2022 21:52:45 -0700 Subject: [PATCH 027/233] fix tak benchmark --- test/bench/koka/tak-int.kk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/bench/koka/tak-int.kk b/test/bench/koka/tak-int.kk index ec2ed3002..a38a5189b 100644 --- a/test/bench/koka/tak-int.kk +++ b/test/bench/koka/tak-int.kk @@ -1,4 +1,4 @@ -module tak +module tak-int pub fun tak(x : int, y : int, z : int ) : div int if y < x From 1c2cebefa7fd56f27f1d3804f681a05812e6e814 Mon Sep 17 00:00:00 2001 From: daan Date: Fri, 22 Apr 2022 11:24:47 -0700 Subject: [PATCH 028/233] improve pyth test, add tagged integer ability for benchmarking --- kklib/include/kklib.h | 2 +- kklib/include/kklib/integer.h | 46 +++++++++++++++++++++++++++++++++-- lib/std/core.kk | 7 ++++++ lib/std/num/int32.kk | 5 ++++ test/bench/koka/cfold.kk | 7 ++++++ test/bench/koka/pyth-int.kk | 20 ++++++--------- test/bench/koka/pyth.kk | 22 +++++++---------- 7 files changed, 81 insertions(+), 28 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 1d2f204bb..8c413a56f 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -2,7 +2,7 @@ #ifndef KKLIB_H #define KKLIB_H -#define KKLIB_BUILD 89 // modify on changes to trigger recompilation +#define KKLIB_BUILD 90 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 866634372..0a641479c 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -149,7 +149,7 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. --------------------------------------------------------------------------------------------------*/ #if !defined(KK_USE_BUILTIN_OVF) -#define KK_USE_BUILTIN_OVF (0) // portable overflow detection seems always faster +#define KK_USE_BUILTIN_OVF (1) // portable overflow detection seems always faster #endif #if KK_USE_BUILTIN_OVF @@ -451,7 +451,7 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: we check before multiply for small integers and do not combine with the overflow check. -----------------------------------------------------------------------------------*/ -#if KK_USE_BUILTIN_OVF +#if (KK_USE_BUILTIN_OVF == 1) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; @@ -493,6 +493,48 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, return _kk_new_integer(z|1); } +#elif (KK_USE_BUILTIN_OVF == 2) // test for small ints upfront + +static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z; + if (kk_unlikely(!kk_are_smallints(x, y) || __builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z))) { + return kk_integer_add_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 2); + return _kk_new_integer(z ^ 3); +} + +static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_intf_t z; + if (kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i, 2), &z))) { + return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + } + kk_assert_internal((z & 3) == 1); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z; + if (kk_unlikely(!kk_are_smallints(x, y) || __builtin_sub_overflow(_kk_integer_value(x) ^ 3, _kk_integer_value(y), &z))) { + return kk_integer_sub_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 1); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_assert_internal(kk_are_smallints(x, y)); + kk_intf_t i = kk_sar(_kk_integer_value(x), 1); + kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t z; + if (kk_unlikely(__builtin_mul_overflow(i, j, &z))) { + return kk_integer_mul_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 0); + return _kk_new_integer(z | 1); +} + #else // use SOFA // we can either mask on the left side or on the sign extended right side. diff --git a/lib/std/core.kk b/lib/std/core.kk index 65d469ced..1c8578ff5 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1055,6 +1055,13 @@ pub fun fold-int( start : int, end : int, init : a, f : (int,a) -> e a ) : e a pub fun fold-int( upto : int, init : a, f : (int,a) -> e a ) : e a fold-int( 0, upto.dec, init, f ) + +pub fun fold-while-int( start : int, end : int, init : a, f : (int,a) -> e maybe ) : e a + if start >= end then init else + match f(start,init) + Just(x) -> fold-while-int(unsafe-decreasing(start.inc), end, x, f) + Nothing -> init + // ---------------------------------------------------------------------------- // 32-bit integers // Just define the operations needed for defining the std/core interface but diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index bbb731f27..7e5aa67ee 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -349,6 +349,11 @@ pub fun fold-int32( start : int32, end : int32, init : a, f : (int32,a) -> e a ) val x = f(start,init) fold-int32(unsafe-decreasing(start.inc), end, x, f) +pub fun fold-while-int32( start : int32, end : int32, init : a, f : (int32,a) -> e maybe ) : e a + if (start >= end) then init else + match f(start,init) + Just(x) -> fold-while-int32(unsafe-decreasing(start.inc), end, x, f) + Nothing -> init // Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). diff --git a/test/bench/koka/cfold.kk b/test/bench/koka/cfold.kk index 78a59ddb0..2f99e1fff 100644 --- a/test/bench/koka/cfold.kk +++ b/test/bench/koka/cfold.kk @@ -59,6 +59,13 @@ fun eval(e : expr) : int Mul(l,r) -> eval(l) * eval(r) +pub fun test() : () + repeat(100) + val e = mk_expr(16,1) + val v1 = eval(e) + val v2 = e.reassoc.cfold.eval + () + pub fun main() : () val e = mk_expr(20,1) val v1 = eval(e) diff --git a/test/bench/koka/pyth-int.kk b/test/bench/koka/pyth-int.kk index 1e5f0354e..2622d5561 100644 --- a/test/bench/koka/pyth-int.kk +++ b/test/bench/koka/pyth-int.kk @@ -1,19 +1,15 @@ module pyth-int -pub fun pyth(n : int ) : int - var count := 0 - for(1, n/3) fn(x) +pub fun pyth(n : int ) : int + fold-int(1, n/3, 0) fn(x,xcount) val xx = x*x - for(x+1, n/2) fn(y) + fold-int(x.inc, n/2, xcount) fn(y,ycount) val yy = y*y - for-while( y+1, n/2) fn(z) + fold-while-int( y.inc, n/2, ycount) fn(z, zcount) val zz = z*z - if (xx+yy == zz) then count := count + 1 - if (xx+yy < zz) || (x+y+z > n) - then Just(()) - else Nothing - () - count - + if (xx+yy == zz) then Just(zcount + 1) + elif (xx+yy >= zz) && (x+y+z <= n) then Just(zcount) + else Nothing + pub fun main() pyth(4000).println \ No newline at end of file diff --git a/test/bench/koka/pyth.kk b/test/bench/koka/pyth.kk index 10c060f63..64e3d5ca6 100644 --- a/test/bench/koka/pyth.kk +++ b/test/bench/koka/pyth.kk @@ -2,20 +2,16 @@ module pyth import std/num/int32 -pub fun pyth(n : int32 ) : int - var count := 0 - for32(1.int32, n/3.int32) fn(x) +pub fun pyth(n : int32 ) : console int32 + fold-int32(1.int32, n/3.int32, 0.int32) fn(x,xcount) val xx = x*x - for32(x.inc, n/2.int32) fn(y) + fold-int32(x.inc, n/2.int32, xcount) fn(y,ycount) val yy = y*y - for-while32( y.inc, n/2.int32) fn(z) + fold-while-int32( y.inc, n/2.int32, ycount) fn(z:int32, zcount:int32) val zz = z*z - if (xx+yy == zz) then count := count + 1 - if (xx+yy < zz) || (x+y+z > n) - then Just(()) - else Nothing - () - count - + if (xx+yy == zz) then Just(zcount + 1.int32) + elif (xx+yy >= zz) && (x+y+z <= n) then Just(zcount) + else Nothing + pub fun main() - pyth(4000.int32).println \ No newline at end of file + pyth(4000.int32).int.println \ No newline at end of file From fc1de65a945512871fd22d52d87ebac6971ea2ff Mon Sep 17 00:00:00 2001 From: daan Date: Fri, 22 Apr 2022 16:30:46 -0700 Subject: [PATCH 029/233] set data def value to auto for effect datatypes --- kklib/include/kklib.h | 2 +- kklib/include/kklib/integer.h | 2 +- src/Syntax/Parse.hs | 2 +- src/Type/TypeVar.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 8c413a56f..ed9f277aa 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -2,7 +2,7 @@ #ifndef KKLIB_H #define KKLIB_H -#define KKLIB_BUILD 90 // modify on changes to trigger recompilation +#define KKLIB_BUILD 89 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 0a641479c..c922032d3 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -149,7 +149,7 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. --------------------------------------------------------------------------------------------------*/ #if !defined(KK_USE_BUILTIN_OVF) -#define KK_USE_BUILTIN_OVF (1) // portable overflow detection seems always faster +#define KK_USE_BUILTIN_OVF (0) // portable overflow detection seems always faster #endif #if KK_USE_BUILTIN_OVF diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index d37a84ba4..5893ddede 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -818,7 +818,7 @@ makeEffectDecl decl = evName = newName "ev" evFld = ValueBinder evName evTp Nothing irng rng evCon = UserCon (toConstructorName id) [] [(Private,evFld)] Nothing irng rng Private "" - in (DataType ename tpars [evCon] rng vis Inductive (DataDefValue 0 0) False docx + in (DataType ename tpars [evCon] rng vis Inductive (DataDefAuto {-DataDefValue 0 0-}) False docx ,(\action -> Lam [ValueBinder evName Nothing Nothing irng rng] (App (action) [(Nothing,App (Var (toConstructorName id) False rng) [(Nothing,Var evName False rng)] rng)] rng) rng)) diff --git a/src/Type/TypeVar.hs b/src/Type/TypeVar.hs index bd2cf0a90..cd822f949 100644 --- a/src/Type/TypeVar.hs +++ b/src/Type/TypeVar.hs @@ -114,7 +114,7 @@ subNew sub -- assertion "Type.TypeVar.subNew.Tau" (all isTau taus) $ let s = assertion ("Type.TypeVar.subNew.KindMismatch: length " ++ show (length sub) ++ ": " ++ unlines (map (\(x,t) -> "(" ++ showTypeVar x ++ " |-> " ++ showTp t ++ ")") sub)) - (all (\(x, t) -> getKind x == getKind t) sub) $ + (all (\(x, t) -> getKind x == getKind t) sub) $ Sub (M.fromList sub) in seq s s From 510d3bd4a82b97faf0c4296be5b3ab29b333158a Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 12 May 2022 16:24:56 -0700 Subject: [PATCH 030/233] make integer arithmetic parameters nicer for benchmarking --- kklib/include/kklib.h | 46 +++++++++++++++++++++++++++++++---- kklib/include/kklib/integer.h | 30 ++++++++++++++--------- test/bench/koka/sfib-int.kk | 21 ++++++++++------ test/bench/koka/sfib.kk | 11 ++++++--- 4 files changed, 80 insertions(+), 28 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index ed9f277aa..594f7f9f0 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1,11 +1,6 @@ #pragma once #ifndef KKLIB_H #define KKLIB_H - -#define KKLIB_BUILD 89 // modify on changes to trigger recompilation -#define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only -// #define KK_DEBUG_FULL 1 // set to enable full internal debug checks - /*--------------------------------------------------------------------------- Copyright 2020-2022, Microsoft Research, Daan Leijen. @@ -13,6 +8,22 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ + +#define KKLIB_BUILD 91 // modify on changes to trigger recompilation +#define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only +// #define KK_DEBUG_FULL 1 // set to enable full internal debug checks + +// Integer arithmetic method +#define KK_INT_USE_OVF 1 // use limited tag bits and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_TAGOVF 2 // use tag bits (upfront check) and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits +#define KK_INT_USE_RENO 4 // use range extended overflow arithmetic + +#ifndef KK_INT_ARITHMETIC +#define KK_INT_ARITHMETIC KK_INT_USE_SOFA +#endif + +// Includes #define WIN32_LEAN_AND_MEAN // reduce windows includes #define _POSIX_C_SOURCE 200809L // make posix definitions visible #define _DARWIN_C_SOURCE 200809L // make darwin definitions visible @@ -166,6 +177,31 @@ typedef struct kk_datatype_s { static inline kk_intf_t kk_intf_unbox(kk_box_t v); static inline kk_box_t kk_intf_box(kk_intf_t u); +#if (KK_FIELD_COMPRESS==4) && (KK_INTPTR_SIZE >= 8) +typedef int32_t kk_field_t; + +static inline kk_box_t kk_field_uncompress(void* blk, kk_field_t field) { + kk_box_t b = { (uintptr_t)((intptr_t)blk + field) }; + return b; +} + +static inline kk_field_t kk_field_compress(void* blk, kk_box_t x) { + intptr_t diff = (intptr_t)(x.box) - (intptr_t)blk); + assert_internal(diff >= INT32_MIN && diff <= INT32_MAX); + return (int32_t)diff; +} + +#define kk_field_tp(tp) kk_field_t +#define kk_field(tp,blk,field_name,ctx) kk_field_uncompress(blk,(blk)->field_name) +#define kk_field_set(tp,blk,field_name,x,ctx) (blk)->field_name = kk_field_compress(blk,(blk)->field_name) + +#else +typedef kk_box_t kk_field_t; + +#define kk_field_tp(tp) kk_field_t +#define kk_field(tp,blk,field_name,ctx) (blk)->field_name +#define kk_field_set(tp,blk,field_name,x,ctx) (blk)->field_name = x +#endif /*-------------------------------------------------------------------------------------- Blocks diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index c922032d3..a4269af15 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -148,11 +148,7 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. -- Daan Leijen, 2020-2022. --------------------------------------------------------------------------------------------------*/ -#if !defined(KK_USE_BUILTIN_OVF) -#define KK_USE_BUILTIN_OVF (0) // portable overflow detection seems always faster -#endif - -#if KK_USE_BUILTIN_OVF +#if KK_INT_ARITHMETIC != KK_INT_USE_SOFA typedef kk_intf_t kk_smallint_t; #define KK_SMALLINT_BITS (KK_INTF_BITS) #elif KK_INTF_SIZE>=16 @@ -257,14 +253,24 @@ static inline kk_integer_t kk_integer_unbox(kk_box_t b) { return i; } +#ifdef KK_INT_NOREFCOUNT static inline kk_integer_t kk_integer_dup(kk_integer_t i) { - if (kk_unlikely(kk_is_bigint(i))) { kk_block_dup(_kk_integer_ptr(i)); } return i; } static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { + kk_unused(i); kk_unused(ctx); +} +#else +static inline kk_integer_t kk_integer_dup(kk_integer_t i) { + if (kk_unlikely(kk_is_bigint(i))) { kk_block_dup(_kk_integer_ptr(i)); } + return i; +} + +static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { if (kk_unlikely(kk_is_bigint(i))) { kk_block_drop(_kk_integer_ptr(i), ctx); } } +#endif kk_decl_export bool kk_integer_parse(const char* num, kk_integer_t* result, kk_context_t* ctx); kk_decl_export bool kk_integer_hex_parse(const char* s, kk_integer_t* res, kk_context_t* ctx); @@ -451,7 +457,7 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: we check before multiply for small integers and do not combine with the overflow check. -----------------------------------------------------------------------------------*/ -#if (KK_USE_BUILTIN_OVF == 1) +#if (KK_INT_ARITHMETIC == KK_INT_USE_OVF) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; @@ -493,7 +499,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, return _kk_new_integer(z|1); } -#elif (KK_USE_BUILTIN_OVF == 2) // test for small ints upfront +#elif (KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF) // test for small ints upfront static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; @@ -540,12 +546,12 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, // we can either mask on the left side or on the sign extended right side. // it turns out that this affects the quality of the generated instructions and we pick depending on the platform #if defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64) -#define KK_SOFA_MASK_RIGHT /* only on x86 and x64 is masking on the sign-extended right side better */ +#define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - #ifndef KK_SOFA_MASK_RIGHT + #ifndef KK_INT_SOFA_RIGHT_BIAS if (kk_likely((z|2) == (kk_smallint_t)z)) // set bit 1 and compare sign extension #else if (kk_likely(z == ((kk_smallint_t)z|2))) @@ -560,7 +566,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); - #ifndef KK_SOFA_MASK_RIGHT + #ifndef KK_INT_SOFA_RIGHT_BIAS if (kk_likely((z|1) == (kk_smallint_t)z)) #else if (kk_likely(z == ((kk_smallint_t)z|1))) @@ -575,7 +581,7 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = (_kk_integer_value(x)^3) - _kk_integer_value(y); - #ifndef KK_SOFA_MASK_RIGHT + #ifndef KK_INT_SOFA_RIGHT_BIAS if (kk_likely((z&~2) == (kk_smallint_t)z)) // clear bit 1 and compare sign extension #else if (kk_likely(z == ((kk_smallint_t)z&~2))) diff --git a/test/bench/koka/sfib-int.kk b/test/bench/koka/sfib-int.kk index 01d584b34..f82ea195a 100644 --- a/test/bench/koka/sfib-int.kk +++ b/test/bench/koka/sfib-int.kk @@ -1,12 +1,19 @@ module sfib-int -fun sfibx(n : int, x1 : int, x2 : int) : div int - if n <= 0 - then x1 - else sfibx(n - 1, x2, (x1 + x2) / (x2 - x1)) +fun sfibx(n : int, x : int) : div int + if n <= 0 then x + elif x > 1000000000 + then sfibx(n - 1, 1) + else sfibx(n - 1, x*x + x + 2) -fun sfib(n : int) - sfibx(n,2,8) +pub fun sfib(n : int) + sfibx(n,1) + +pub fun test(n : int) + val xs = list(1,10000) + val ssum = fold-int(1,n,0) fn(i,acc) + acc + xs.sum + ssum.println pub fun main() - sfib(100000000).println \ No newline at end of file + test(100000) \ No newline at end of file diff --git a/test/bench/koka/sfib.kk b/test/bench/koka/sfib.kk index bc415abcb..290119bc1 100644 --- a/test/bench/koka/sfib.kk +++ b/test/bench/koka/sfib.kk @@ -3,12 +3,15 @@ module sfib import std/num/int32 fun sfibx(n : int32, x1 : int32, x2 : int32) : div int32 - if n <= zero + if n <= 0.int32 then x1 - else sfibx(n.dec, x2, (x1 + x2) / (x2 - x1)) + elif x2 > 1000000000.int32 + then sfibx(n.dec, 1.int32, 2.int32) + else sfibx(n.dec, x2 - x1, x1 * x2 + x1) fun sfib(n : int) - sfibx(n.int32,2.int32,8.int32).int + sfibx(n.int32,1.int32,2.int32).int pub fun main() - sfib(100000000).println \ No newline at end of file + sfib(50000000).println + From dd1da53f19f31d3a5c19a3d90507622d7128ba3d Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 12 May 2022 19:04:31 -0700 Subject: [PATCH 031/233] add initial reno style arithmetic for experimentation --- kklib/include/kklib.h | 4 +- kklib/include/kklib/integer.h | 95 ++++++++++++++++++++++++++++++++++- 2 files changed, 96 insertions(+), 3 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 594f7f9f0..123dea281 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 91 // modify on changes to trigger recompilation +#define KKLIB_BUILD 92 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks @@ -20,7 +20,7 @@ #define KK_INT_USE_RENO 4 // use range extended overflow arithmetic #ifndef KK_INT_ARITHMETIC -#define KK_INT_ARITHMETIC KK_INT_USE_SOFA +#define KK_INT_ARITHMETIC KK_INT_USE_RENO #endif // Includes diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index a4269af15..6dbb42f66 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -175,6 +175,7 @@ static inline kk_intf_t _kk_integer_value(kk_integer_t i) { return (kk_intf_t)i.ibox; // potentially cast to smaller kk_intf_t (as on arm CHERI) } +#if KK_INT_ARITHMETIC != KK_INT_USE_RENO static inline bool kk_is_smallint(kk_integer_t i) { return ((_kk_integer_value(i)&1) != 0); } @@ -214,12 +215,61 @@ static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { //return ((_kk_integer_value(i)&1)==1 || (_kk_integer_value(j)&1)==1); } +#else +#define KK_INT_MINPTR (KK_IF(1) << (KK_SMALLINT_BITS - 2)) + +static inline bool kk_is_smallint(kk_integer_t i) { + return (_kk_integer_value(i) <= KK_INT_MINPTR); + // return (_kk_integer_value(i) <= KK_SMALLINT_MAX); + // return (kk_sarf(_kk_integer_value(i), KK_SMALLINT_BITS - 2) <= 0); +} + +static inline bool kk_is_bigint(kk_integer_t i) { + return !kk_is_smallint(i); +} + +static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { + kk_assert_internal(kk_is_bigint(i)); + return (kk_ptr_t)(i.ibox - KK_INT_MINPTR); +} + +static inline kk_integer_t _kk_new_integer(kk_intf_t i) { + kk_integer_t z = { (uintptr_t)i }; // todo: optimize in case sizeof(kk_intf_t) < sizeof(intptr_t) ? + return z; +} + +static inline kk_intf_t kk_smallint_from_integer(kk_integer_t i) { // use for known small ints + kk_assert_internal(kk_is_smallint(i) && (_kk_integer_value(i) >= KK_SMALLINT_MIN)); + return _kk_integer_value(i); +} + +static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for known small int constants (at most 14 bits) + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + return _kk_new_integer(i); +} + +static inline kk_integer_t kk_integer_from_ptr(kk_block_t* p) { // use for known small int constants (at most 14 bits) + kk_integer_t z = { (uintptr_t)p + KK_INT_MINPTR }; + return z; +} + +static inline bool kk_is_integer(kk_integer_t i) { + return ((kk_is_smallint(i) && kk_smallint_from_integer(i) >= KK_SMALLINT_MIN && kk_smallint_from_integer(i) <= KK_SMALLINT_MAX) + || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i)) == KK_TAG_BIGINT)); +} + +static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { + kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); + return (kk_is_smallint(i) && kk_is_smallint(j)); +} +#endif + + static inline bool kk_integer_small_eq(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); return (_kk_integer_value(x) == _kk_integer_value(y)); } - #define kk_integer_zero (kk_integer_from_small(0)) #define kk_integer_one (kk_integer_from_small(1)) #define kk_integer_min_one (kk_integer_from_small(-1)) @@ -243,6 +293,7 @@ static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { Generic operations on integers -----------------------------------------------------------------------------------*/ +#if KK_INT_ARITHMETIC != KK_INT_USE_RENO // Isomorphic with boxed values static inline kk_box_t kk_integer_box(kk_integer_t i) { kk_box_t b = { i.ibox }; @@ -252,6 +303,14 @@ static inline kk_integer_t kk_integer_unbox(kk_box_t b) { kk_integer_t i = { b.box }; return i; } +#else +static inline kk_box_t kk_integer_box(kk_integer_t i) { + return (kk_is_smallint(i) ? kk_intf_box(kk_smallint_from_integer(i)) : kk_ptr_box(_kk_integer_ptr(i))); +} +static inline kk_integer_t kk_integer_unbox(kk_box_t b) { + return (kk_box_is_value(b) ? kk_integer_from_small(kk_intf_unbox(b)) : kk_integer_from_ptr(kk_ptr_unbox(b))); +} +#endif #ifdef KK_INT_NOREFCOUNT static inline kk_integer_t kk_integer_dup(kk_integer_t i) { @@ -541,6 +600,40 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, return _kk_new_integer(z | 1); } + +#elif (KK_INT_ARITHMETIC == KK_INT_USE_RENO) + +static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); + if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_add_generic(x, y, ctx); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_intf_t z = _kk_integer_value(x) + i; + if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); +#if defined(__GCC__) && defined(__aarch64__) + if (kk_unlikely(_kk_integer_value(y) > KK_INT_MINPTR + 1 || z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_sub_generic(x, y, ctx); +#else + if (kk_unlikely(_kk_integer_value(y) > KK_INT_MINPTR + 1)) return kk_integer_sub_generic(x, y, ctx); + if (kk_unlikely((kk_intf_t)((kk_uintf_t)z + KK_INT_MINPTR) < 0)) return kk_integer_sub_generic(x, y, ctx); +#endif + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_assert_internal(kk_are_smallints(x, y)); + kk_intf_t z = kk_smallint_from_integer(x) * kk_smallint_from_integer(y); + if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_mul_generic(x, y, ctx); + return _kk_new_integer(z); +} + #else // use SOFA // we can either mask on the left side or on the sign extended right side. From 7890d0f264f7a76788e15bd2d1afa748c2aa1764 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 12 May 2022 19:04:50 -0700 Subject: [PATCH 032/233] set default arithmetic to sofa --- kklib/include/kklib.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 123dea281..7c9eab21d 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -20,7 +20,7 @@ #define KK_INT_USE_RENO 4 // use range extended overflow arithmetic #ifndef KK_INT_ARITHMETIC -#define KK_INT_ARITHMETIC KK_INT_USE_RENO +#define KK_INT_ARITHMETIC KK_INT_USE_SOFA #endif // Includes From 7c6d3b563a2ac94b68259599ac2c75391451639d Mon Sep 17 00:00:00 2001 From: daan Date: Fri, 13 May 2022 21:11:26 -0700 Subject: [PATCH 033/233] add reno32 arithmetic and xsofa --- kklib/include/kklib/integer.h | 176 ++++++++++++++++++++++++++++------ 1 file changed, 145 insertions(+), 31 deletions(-) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 6dbb42f66..1f4b1cc5d 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -148,7 +148,11 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. -- Daan Leijen, 2020-2022. --------------------------------------------------------------------------------------------------*/ -#if KK_INT_ARITHMETIC != KK_INT_USE_SOFA +#ifndef KK_INT_TAG +#define KK_INT_TAG (1) +#endif + +#if KK_INT_ARITHMETIC == KK_INT_USE_OVF || KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF typedef kk_intf_t kk_smallint_t; #define KK_SMALLINT_BITS (KK_INTF_BITS) #elif KK_INTF_SIZE>=16 @@ -167,8 +171,14 @@ typedef int8_t kk_smallint_t; # error "platform must be 16, 32, 64, or 128 bits." #endif +#if KK_INT_ARITHMETIC != KK_INT_USE_RENO +#define KK_INT_TAG_BITS (2) +#else +#define KK_INT_TAG_BITS (0) +#endif + #define KK_SMALLINT_SIZE (KK_SMALLINT_BITS/8) -#define KK_SMALLINT_MAX (KK_INTF_MAX >> (KK_INTF_BITS - KK_SMALLINT_BITS + 2)) +#define KK_SMALLINT_MAX (KK_INTF_MAX >> (KK_INTF_BITS - KK_SMALLINT_BITS + KK_INT_TAG_BITS)) #define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) static inline kk_intf_t _kk_integer_value(kk_integer_t i) { @@ -177,16 +187,24 @@ static inline kk_intf_t _kk_integer_value(kk_integer_t i) { #if KK_INT_ARITHMETIC != KK_INT_USE_RENO static inline bool kk_is_smallint(kk_integer_t i) { + #if KK_INT_TAG==1 return ((_kk_integer_value(i)&1) != 0); + #else + return ((_kk_integer_value(i)&1) == 0); + #endif } static inline bool kk_is_bigint(kk_integer_t i) { - return ((_kk_integer_value(i)&1) == 0); + return !kk_is_smallint(i); } static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { kk_assert_internal(kk_is_bigint(i)); + #if KK_INT_TAG==1 return (kk_ptr_t)(i.ibox); + #else + return (kk_ptr_t)(i.ibox ^ 1); + #endif } static inline kk_integer_t _kk_new_integer(kk_intf_t i) { @@ -195,13 +213,13 @@ static inline kk_integer_t _kk_new_integer(kk_intf_t i) { } static inline kk_intf_t kk_smallint_from_integer(kk_integer_t i) { // use for known small ints - kk_assert_internal(kk_is_smallint(i) && (_kk_integer_value(i)&3)==1); - return kk_sarf(_kk_integer_value(i),2); + kk_assert_internal(kk_is_smallint(i)); + return kk_sarf(_kk_integer_value(i),2); } static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for known small int constants (at most 14 bits) kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return _kk_new_integer(kk_shlf(i,2)|1); + return _kk_new_integer(kk_shlf(i,2)|KK_INT_TAG); } static inline bool kk_is_integer(kk_integer_t i) { @@ -211,17 +229,18 @@ static inline bool kk_is_integer(kk_integer_t i) { static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); - return (((_kk_integer_value(i)&_kk_integer_value(j))&1) == 1); + return (((_kk_integer_value(i)&_kk_integer_value(j))&1) == KK_INT_TAG); //return ((_kk_integer_value(i)&1)==1 || (_kk_integer_value(j)&1)==1); } #else -#define KK_INT_MINPTR (KK_IF(1) << (KK_SMALLINT_BITS - 2)) +#define KK_INT_MINPTR (KK_IF(1) << (KK_INTF_BITS - 2)) static inline bool kk_is_smallint(kk_integer_t i) { - return (_kk_integer_value(i) <= KK_INT_MINPTR); - // return (_kk_integer_value(i) <= KK_SMALLINT_MAX); - // return (kk_sarf(_kk_integer_value(i), KK_SMALLINT_BITS - 2) <= 0); + // return (_kk_integer_value(i) <= KK_INT_MINPTR); + return (_kk_integer_value(i) <= KK_SMALLINT_MAX); + //kk_intf_t x = _kk_integer_value(i); + //return (x == (kk_smallint_t)x); } static inline bool kk_is_bigint(kk_integer_t i) { @@ -230,11 +249,11 @@ static inline bool kk_is_bigint(kk_integer_t i) { static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { kk_assert_internal(kk_is_bigint(i)); - return (kk_ptr_t)(i.ibox - KK_INT_MINPTR); + return (kk_ptr_t)(kk_shlp(i.ibox,2)); } static inline kk_integer_t _kk_new_integer(kk_intf_t i) { - kk_integer_t z = { (uintptr_t)i }; // todo: optimize in case sizeof(kk_intf_t) < sizeof(intptr_t) ? + kk_integer_t z = { (uintptr_t)(i) }; return z; } @@ -249,7 +268,7 @@ static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for kno } static inline kk_integer_t kk_integer_from_ptr(kk_block_t* p) { // use for known small int constants (at most 14 bits) - kk_integer_t z = { (uintptr_t)p + KK_INT_MINPTR }; + kk_integer_t z = { kk_shrp((uintptr_t)p,2) | KK_INT_MINPTR }; return z; } @@ -296,11 +315,19 @@ static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { #if KK_INT_ARITHMETIC != KK_INT_USE_RENO // Isomorphic with boxed values static inline kk_box_t kk_integer_box(kk_integer_t i) { + #if KK_INT_TAG == 1 kk_box_t b = { i.ibox }; + #else + kk_box_t b = { i.ibox ^ 1 }; + #endif return b; } static inline kk_integer_t kk_integer_unbox(kk_box_t b) { + #if KK_INT_TAG == 1 kk_integer_t i = { b.box }; + #else + kk_integer_t i = { b.box ^ 1 }; + #endif return i; } #else @@ -603,38 +630,39 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #elif (KK_INT_ARITHMETIC == KK_INT_USE_RENO) +static inline bool kk_is_in_small_range( kk_intf_t i ) { + // return (i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + return (i == (kk_smallint_t)i); +} + static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_add_generic(x, y, ctx); + if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_add_generic(x, y, ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { - kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_assert_internal(kk_is_in_small_range(i)); kk_intf_t z = _kk_integer_value(x) + i; - if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); -#if defined(__GCC__) && defined(__aarch64__) - if (kk_unlikely(_kk_integer_value(y) > KK_INT_MINPTR + 1 || z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_sub_generic(x, y, ctx); -#else - if (kk_unlikely(_kk_integer_value(y) > KK_INT_MINPTR + 1)) return kk_integer_sub_generic(x, y, ctx); - if (kk_unlikely((kk_intf_t)((kk_uintf_t)z + KK_INT_MINPTR) < 0)) return kk_integer_sub_generic(x, y, ctx); -#endif + if (kk_unlikely(!kk_is_smallint(y) || !kk_is_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); - kk_intf_t z = kk_smallint_from_integer(x) * kk_smallint_from_integer(y); - if (kk_unlikely(z > KK_SMALLINT_MAX || z < KK_SMALLINT_MIN)) return kk_integer_mul_generic(x, y, ctx); + kk_intf_t z = _kk_integer_value(x) * _kk_integer_value(y); + // if (kk_unlikely(!kk_are_smallints(x,y))) return kk_integer_mul_generic(x, y, ctx); + if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_mul_generic(x, y, ctx); return _kk_new_integer(z); } -#else // use SOFA +#elif (KK_INT_ARITHMETIC == KK_INT_USE_SOFA) // we can either mask on the left side or on the sign extended right side. // it turns out that this affects the quality of the generated instructions and we pick depending on the platform @@ -642,6 +670,8 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif +#if KK_INT_TAG == 1 + static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); #ifndef KK_INT_SOFA_RIGHT_BIAS @@ -686,6 +716,54 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con return kk_integer_sub_generic(x, y, ctx); } +#else // KK_INT_TAG == 0 + + +static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); + #ifndef KK_INT_SOFA_RIGHT_BIAS + if (kk_likely((z&~3) == (kk_smallint_t)z)) // clear lower 2 bits and compare sign extension + #else + if (kk_likely(z == ((kk_smallint_t)z&~3))) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_add_generic(x, y, ctx); +} + +static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); + #ifndef KK_INT_SOFA_RIGHT_BIAS + if (kk_likely((z&~3) == (kk_smallint_t)z)) + #else + if (kk_likely(z == ((kk_smallint_t)z&~3))) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); +} + + +static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) - (_kk_integer_value(y)^3) + 3; + #ifndef KK_INT_SOFA_RIGHT_BIAS + if (kk_likely((z&~3) == (kk_smallint_t)z)) // clear lower 2 bits and compare sign extension + #else + if (kk_likely(z == ((kk_smallint_t)z&~3))) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_sub_generic(x, y, ctx); +} + +#endif static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); @@ -694,11 +772,13 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t z = i*j; if (kk_likely(z == (kk_smallint_t)(z))) { kk_assert_internal((z&3) == 0); - return _kk_new_integer(z|1); + return _kk_new_integer(z|KK_INT_TAG); } return kk_integer_mul_generic(x, y, ctx); } +#else +#error unknown arithmetic mode! #endif static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -873,49 +953,83 @@ static inline kk_integer_t kk_integer_abs(kk_integer_t x, kk_context_t* ctx) { } static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (_kk_integer_value(x) == _kk_integer_value(y)) return 0; + if (kk_likely(kk_is_smallint(x))) { + if (_kk_integer_value(x) > _kk_integer_value(y)) return 1; + if (kk_likely(kk_is_smallint(y))) return -1; + } + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); + #endif return kk_integer_cmp_generic_borrow(x, y, ctx); } static inline bool kk_integer_lt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) == -1); } static inline bool kk_integer_lt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic(x, y, ctx) == -1); } static inline bool kk_integer_lte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) <= 0); } static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) == 1); } static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic(x, y, ctx) == 1); } static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) >= 0); } static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small - // if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y)); + if (_kk_integer_value(x) == _kk_integer_value(y)) return true; + if (kk_likely(kk_is_smallint(x))) return false; + // if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic_borrow(x, y, ctx) == 0); } static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small - // if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y)); + if (_kk_integer_value(x) == _kk_integer_value(y)) return true; + if (kk_likely(kk_is_smallint(x))) return false; + // if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic(x, y, ctx) == 0); } From 042e33ed437600c279456b237b37a7c98e747237 Mon Sep 17 00:00:00 2001 From: daan Date: Sun, 15 May 2022 13:01:28 -0700 Subject: [PATCH 034/233] add intbench script --- kklib/include/kklib/integer.h | 36 ++++--- test/bench/intbench.sh | 191 +++++++++++++++++++++++++++++++++ test/bench/koka/hamming-int.kk | 17 +++ test/bench/koka/hamming.kk | 19 ++++ 4 files changed, 247 insertions(+), 16 deletions(-) create mode 100644 test/bench/intbench.sh create mode 100644 test/bench/koka/hamming-int.kk create mode 100644 test/bench/koka/hamming.kk diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 1f4b1cc5d..f456bc2a2 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -237,10 +237,11 @@ static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { #define KK_INT_MINPTR (KK_IF(1) << (KK_INTF_BITS - 2)) static inline bool kk_is_smallint(kk_integer_t i) { - // return (_kk_integer_value(i) <= KK_INT_MINPTR); - return (_kk_integer_value(i) <= KK_SMALLINT_MAX); - //kk_intf_t x = _kk_integer_value(i); - //return (x == (kk_smallint_t)x); + //return (_kk_integer_value(i) < KK_INT_MINPTR); + //return (_kk_integer_value(i) <= KK_SMALLINT_MAX); + kk_intf_t x = _kk_integer_value(i); + return (x == (kk_smallint_t)x); + //return ((kk_uintf_t)((x>>32)+1) <= 1); } static inline bool kk_is_bigint(kk_integer_t i) { @@ -631,7 +632,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #elif (KK_INT_ARITHMETIC == KK_INT_USE_RENO) static inline bool kk_is_in_small_range( kk_intf_t i ) { - // return (i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + //return (i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); return (i == (kk_smallint_t)i); } @@ -649,9 +650,16 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t } static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + #if 1 kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); if (kk_unlikely(!kk_is_smallint(y) || !kk_is_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); return _kk_new_integer(z); + #else + kk_intf_t i = _kk_integer_value(x); + kk_intf_t z = i + i - _kk_integer_value(y); + if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); + return _kk_new_integer(z - i); + #endif } static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -666,7 +674,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, // we can either mask on the left side or on the sign extended right side. // it turns out that this affects the quality of the generated instructions and we pick depending on the platform -#if defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64) +#if (defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64)) #define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif @@ -681,7 +689,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con #endif { kk_assert_internal((z&3) == 2); - return _kk_new_integer(z^3); + return _kk_new_integer(z - 1); } return kk_integer_add_generic(x, y, ctx); } @@ -994,7 +1002,7 @@ static inline bool kk_integer_lte_borrow(kk_integer_t x, kk_integer_t y, kk_cont static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(y)); #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); #endif @@ -1003,7 +1011,7 @@ static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_conte static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(y)); #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); #endif @@ -1022,7 +1030,7 @@ static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_cont static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; if (kk_likely(kk_is_smallint(x))) return false; - // if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small + //if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic_borrow(x, y, ctx) == 0); } @@ -1034,15 +1042,11 @@ static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* c } static inline bool kk_integer_neq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) != _kk_integer_value(y)); // assume bigint is never small - // if (kk_are_smallints(x,y)) return (_kk_integer_value(x) != _kk_integer_value(y)); - return (kk_integer_cmp_generic_borrow(x, y, ctx) != 0); + return !kk_integer_eq_borrow(x,y,ctx); } static inline bool kk_integer_neq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) != _kk_integer_value(y)); // assume bigint is never small - // if (kk_are_smallints(x,y)) return (_kk_integer_value(x) != _kk_integer_value(y)); - return (kk_integer_cmp_generic(x, y, ctx) != 0); + return !kk_integer_eq(x,y,ctx); } static inline bool kk_integer_is_even(kk_integer_t x, kk_context_t* ctx) { diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh new file mode 100644 index 000000000..bc33e96ff --- /dev/null +++ b/test/bench/intbench.sh @@ -0,0 +1,191 @@ +all_variants="int32 ovf tagovf sofa xsofa reno" +all_compilers="clang gcc" +all_benches="nqueens hamming pyth tak" + +variants="int32" +compilers="clang" +benches="" + +intopts="" +benchdir="test/bench/koka/" +verbose="no" + +do_build="no" +do_run="no" +max_runs=1 + +function info { + echo $1 +} + +function warning { + echo "" + echo "warning: $1" +} + +while : ; do + # set flag and flag_arg + flag="$1" + case "$flag" in + *=*) flag_arg="${flag#*=}" + flag="${flag%=*}";; + no-*) flag_arg="0" + flag="${flag#no-}";; + none) flag_arg="0" ;; + *) flag_arg="1" ;; + esac + case "$flag_arg" in + yes|on|true) flag_arg="1";; + no|off|false) flag_arg="0";; + esac + case "$flag" in + "") break;; + + allb) benches="$all_benches";; + allc) compilers="$all_compilers";; + allv) variants="$all_variants";; + + nqueens) benches="$benches nqueens";; + hamming) benches="$benches hamming";; + pyth) benches="$benches pyth";; + tak) benches="$benches tak";; + + ovf) variants="$variants ovf";; + tagovf) variants="$variants tagovf";; + sofa) variants="$variants sofa";; + xsofa) variants="$variants xsofa";; + reno) variants="$variants reno";; + + gcc) compilers="$compilers gcc";; + gcc-11) compilers="$compilers gcc-11";; + + build) do_build="yes";; + run) do_run="yes";; + + -n) + max_runs=$flag_arg;; + + -v|--verbose) + verbose="yes";; + -h|--help|-\?|help|\?) + echo "./intbench.sh [options]" + echo "" + echo "options:" + echo " -h, --help show this help" + echo " -v, --verbose be verbose (=$verbose)" + echo "" + exit 0;; + *) warning "unknown option \"$1\"." 1>&2 + esac + shift +done + + +function set_intopts { # + case "$1" in + ovf) intopts="--ccopts=-DKK_INT_ARITHMETIC=1";; + tagovf) intopts="--ccopts=-DKK_INT_ARITHMETIC=2";; + sofa) intopts="--ccopts=-DKK_INT_ARITHMETIC=3";; + reno) intopts="--ccopts=-DKK_INT_ARITHMETIC=4";; + xsofa) intopts="--ccopts=-DKK_INT_ARITHMETIC=3 --ccopts=-DKK_INT_TAG=0";; + *) intopts="";; + esac; +} + +function build { # + local options="-O2 --cc=$3 --buildtag=$2" + if [ "$2" = "int32" ]; then + options="$options -c $benchdir$1.kk" + else + set_intopts "$2" + options="$options --ccopts=-DKK_INT_NOREFCOUNT $intopts -c $benchdir$1-int.kk" + fi + info "" + info "build: $1, variant: $2, cc: $3, ($options)" + stack exec koka -- $options +} + +function build_all { + for ccomp in $compilers; do + for bench in $benches; do + for variant in $variants; do + build $bench $variant $ccomp + done + done + done +} + + +function run { #bench variant cc runidx log + local bench="" + if [ "$2" = "int32" ]; then + bench="$1" + else + bench="$1_dash_int" + fi + cmd=".koka/v2.4.1-$2/$3-drelease/test_bench_koka_$bench" + info "" + info "run $4, $1-$3-$2, cmd: $cmd" + local logrun=".koka/intbench/run.txt" + $cmd --kktime 2> $logrun + cat $logrun + # extract elapsed time + local line=`head -1 $logrun` + line=${line#info: elapsed: } + local elapsed=${line/s,*/} + echo "$elapsed" >> "$5" +} + +function run_all { + for ccomp in $compilers; do + for bench in $benches; do + for variant in $variants; do + for ((runs=1; runs<=$max_runs; runs++)); do + local log=".koka/intbench/$bench-$ccomp-$variant.txt" + echo "" > log + run $bench $variant $ccomp $runs $log + done + done + done + done +} + +basetime="" + +function avg { #bench variant cc logall + local log=".koka/intbench/$1-$3-$2.txt" + local median=`sort -n $log | awk ' { a[i++]=$1; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + local stddev=`awk ' { sum += $1; sumsq += ($1)^2; } END { print sqrt((sumsq - sum^2/NR)/NR); }' < $log` + if [ "$basetime" = "" ]; then + basetime="$median" + fi + local rmedian=`echo "scale=3; $median / $basetime" | bc` + local rstddev=`echo "scale=3; $rmedian * $stddev" | bc` + echo "$1-$3-$2 ${median}s ${rmedian}x ${rstddev}" >> $4 +} + +function avg_all { + for bench in $benches; do + local logall=".koka/intbench/$bench.txt" + basetime="" + echo "" > $logall + for ccomp in $compilers; do + for variant in $variants; do + avg $bench $variant $ccomp $logall + done + done + echo "" + echo "# benchmark elapsed relat. stddev" + column -t $logall + done +} + + +if [ "$do_build" = "yes" ]; then + build_all +fi + +if [ "$do_run" = "yes" ]; then + run_all + avg_all +fi \ No newline at end of file diff --git a/test/bench/koka/hamming-int.kk b/test/bench/koka/hamming-int.kk new file mode 100644 index 000000000..9a9d995a5 --- /dev/null +++ b/test/bench/koka/hamming-int.kk @@ -0,0 +1,17 @@ +// Euclid's gcd with subtraction +fun gcd( x : int, y : int ) : div int + if x > y + then gcd( x - y, y ) + elif x < y + then gcd( x, y - x ) + else x + +fun is-hamming( x : int ) : div bool + gcd(x,42) == 1 + +fun hamming-last( upto : int ) : div int + fold-int(1,upto,0) fn(i,acc) + if is-hamming(i) then i else acc + +fun main() + hamming-last(300000).println \ No newline at end of file diff --git a/test/bench/koka/hamming.kk b/test/bench/koka/hamming.kk new file mode 100644 index 000000000..98d10e338 --- /dev/null +++ b/test/bench/koka/hamming.kk @@ -0,0 +1,19 @@ +import std/num/int32 + +// Euclid's gcd with subtraction +fun gcd( x : int32, y : int32 ) : div int32 + if x > y + then gcd( x - y, y ) + elif x < y + then gcd( x, y - x ) + else x + +fun is-hamming( x : int32 ) : div bool + gcd(x,42.int32) == 1.int32 + +fun hamming-last( upto : int ) : div int32 + fold-int32(1.int32,upto.int32,0.int32) fn(i,acc) + if is-hamming(i) then i else acc + +fun main() + hamming-last(300000).int.println \ No newline at end of file From 0b04c38465f4b6d56f0aaf4638f24a9eadd28583 Mon Sep 17 00:00:00 2001 From: daan Date: Mon, 16 May 2022 08:06:21 -0700 Subject: [PATCH 035/233] fix intbench --- kklib/include/kklib/integer.h | 33 +++++++++++++++++---------------- test/bench/intbench.sh | 9 ++++++--- 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index f456bc2a2..b3b5968b2 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -269,7 +269,8 @@ static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for kno } static inline kk_integer_t kk_integer_from_ptr(kk_block_t* p) { // use for known small int constants (at most 14 bits) - kk_integer_t z = { kk_shrp((uintptr_t)p,2) | KK_INT_MINPTR }; + //kk_integer_t z = { kk_shrp((uintptr_t)p,2) | KK_INT_MINPTR }; + kk_integer_t z = { kk_bits_rotr((uintptr_t)p+1,2) }; // avoid large constants in code (use + instead of | for clang codegen) return z; } @@ -631,33 +632,33 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #elif (KK_INT_ARITHMETIC == KK_INT_USE_RENO) -static inline bool kk_is_in_small_range( kk_intf_t i ) { +static inline bool kk_not_in_small_range( kk_intf_t i ) { //return (i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return (i == (kk_smallint_t)i); + return ((kk_smallint_t)i != i); } static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_add_generic(x, y, ctx); + if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_add_generic(x, y, ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { - kk_assert_internal(kk_is_in_small_range(i)); kk_intf_t z = _kk_integer_value(x) + i; - if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if 1 + #if 0 kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); - if (kk_unlikely(!kk_is_smallint(y) || !kk_is_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); + if (kk_unlikely(!kk_is_smallint(y) || kk_not_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); + //if (kk_unlikely(!kk_is_smallint(y))) return kk_integer_add_generic(x,y,ctx); return _kk_new_integer(z); #else - kk_intf_t i = _kk_integer_value(x); - kk_intf_t z = i + i - _kk_integer_value(y); - if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); + const kk_intf_t i = _kk_integer_value(x); + const kk_intf_t z = i + i - _kk_integer_value(y); + if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); return _kk_new_integer(z - i); #endif } @@ -666,7 +667,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_assert_internal(kk_are_smallints(x, y)); kk_intf_t z = _kk_integer_value(x) * _kk_integer_value(y); // if (kk_unlikely(!kk_are_smallints(x,y))) return kk_integer_mul_generic(x, y, ctx); - if (kk_unlikely(!kk_is_in_small_range(z))) return kk_integer_mul_generic(x, y, ctx); + if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_mul_generic(x, y, ctx); return _kk_new_integer(z); } @@ -674,7 +675,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, // we can either mask on the left side or on the sign extended right side. // it turns out that this affects the quality of the generated instructions and we pick depending on the platform -#if (defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64)) +#if defined(__clang__) && (defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64)) #define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif @@ -689,7 +690,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con #endif { kk_assert_internal((z&3) == 2); - return _kk_new_integer(z - 1); + return _kk_new_integer(z^3); } return kk_integer_add_generic(x, y, ctx); } @@ -1036,13 +1037,13 @@ static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_conte static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; - if (kk_likely(kk_is_smallint(x))) return false; + if (kk_likely(kk_is_smallint(x))) return false; // if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic(x, y, ctx) == 0); } static inline bool kk_integer_neq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - return !kk_integer_eq_borrow(x,y,ctx); + return !kk_integer_eq_borrow(x,y,ctx); } static inline bool kk_integer_neq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh index bc33e96ff..4018794e5 100644 --- a/test/bench/intbench.sh +++ b/test/bench/intbench.sh @@ -7,6 +7,7 @@ compilers="clang" benches="" intopts="" +ccopts="" benchdir="test/bench/koka/" verbose="no" @@ -62,6 +63,8 @@ while : ; do build) do_build="yes";; run) do_run="yes";; + asm) ccopts="--ccopts=-save-temps";; + -n) max_runs=$flag_arg;; @@ -93,7 +96,7 @@ function set_intopts { # } function build { # - local options="-O2 --cc=$3 --buildtag=$2" + local options="-O2 --cc=$3 --buildtag=$2 $ccopts" if [ "$2" = "int32" ]; then options="$options -c $benchdir$1.kk" else @@ -140,9 +143,9 @@ function run_all { for ccomp in $compilers; do for bench in $benches; do for variant in $variants; do + local log=".koka/intbench/$bench-$ccomp-$variant.txt" + rm -f $log 2> /dev/null for ((runs=1; runs<=$max_runs; runs++)); do - local log=".koka/intbench/$bench-$ccomp-$variant.txt" - echo "" > log run $bench $variant $ccomp $runs $log done done From 6129855a85ba2eed3b12bc87544e5495eed26748 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 16 May 2022 08:07:19 -0700 Subject: [PATCH 036/233] make intbench executable --- test/bench/intbench.sh | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 test/bench/intbench.sh diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh old mode 100644 new mode 100755 From b605b6b5dd488dcc16235e8c02a906edad1c237c Mon Sep 17 00:00:00 2001 From: daan Date: Mon, 16 May 2022 10:04:21 -0700 Subject: [PATCH 037/233] add graph output for intbench --- test/bench/intbench.sh | 71 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 61 insertions(+), 10 deletions(-) diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh index 4018794e5..4e0e5a62c 100644 --- a/test/bench/intbench.sh +++ b/test/bench/intbench.sh @@ -1,8 +1,8 @@ -all_variants="int32 ovf tagovf sofa xsofa reno" +all_variants="sofa int32 ovf tagovf xsofa reno" all_compilers="clang gcc" all_benches="nqueens hamming pyth tak" -variants="int32" +variants="sofa" compilers="clang" benches="" @@ -62,6 +62,7 @@ while : ; do build) do_build="yes";; run) do_run="yes";; + graph) do_graph="yes";; asm) ccopts="--ccopts=-save-temps";; @@ -155,34 +156,80 @@ function run_all { basetime="" -function avg { #bench variant cc logall +function avg { #bench variant cc logbench local log=".koka/intbench/$1-$3-$2.txt" local median=`sort -n $log | awk ' { a[i++]=$1; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` - local stddev=`awk ' { sum += $1; sumsq += ($1)^2; } END { print sqrt((sumsq - sum^2/NR)/NR); }' < $log` + local stddev=`awk ' { sqrsum += ($1 - '"$median"')^2; } END { print sqrt(sqrsum/NR); }' < $log` if [ "$basetime" = "" ]; then basetime="$median" fi local rmedian=`echo "scale=3; $median / $basetime" | bc` local rstddev=`echo "scale=3; $rmedian * $stddev" | bc` - echo "$1-$3-$2 ${median}s ${rmedian}x ${rstddev}" >> $4 + echo "$1 $3 $2 ${median} ${rmedian} ${rstddev}" >> $4 } function avg_all { for bench in $benches; do - local logall=".koka/intbench/$bench.txt" + local logbench=".koka/intbench/$bench.txt" basetime="" - echo "" > $logall + rm -f $logbench 2> /dev/null for ccomp in $compilers; do for variant in $variants; do - avg $bench $variant $ccomp $logall + avg $bench $variant $ccomp $logbench done done echo "" echo "# benchmark elapsed relat. stddev" - column -t $logall + column -t $logbench done } +function graph_variant { # + awk ' + BEGIN { + ccomp="'"$2"'" + variant="'"$1"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $2 == ccomp && $3 == variant { + if ($2 == "clang" && $3 == "sofa") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.3f}}\n", i++, $5, $6, $4 ); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($5>4 ? 4 : $5), $6, $5); + } + } + END { + print "}\\datatime" ccomp (variant=="int32"? "int" : variant) + print " " + } + ' $3 >> $4 +} + +function graph_all { + local logall=".koka/intbench/all.txt" + rm -f $logall 2> /dev/null + for bench in $benches; do + local logbench=".koka/intbench/$bench.txt" + cat $logbench >> $logall + done + local texdata=".koka/intbench/graph.tex" + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + for bench in $benches; do + echo " \\strut $bench," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + for ccomp in $compilers; do + for variant in $variants; do + graph_variant $variant $ccomp $logall $texdata + done + done + cat $texdata +} + if [ "$do_build" = "yes" ]; then build_all @@ -191,4 +238,8 @@ fi if [ "$do_run" = "yes" ]; then run_all avg_all -fi \ No newline at end of file +fi + +if [ "$do_graph" = "yes" ]; then + graph_all +fi \ No newline at end of file From d8ebb2d3d5b8a076441ebd001d52b98d20b0a5a9 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 16 May 2022 10:10:29 -0700 Subject: [PATCH 038/233] fix intbench for mac --- test/bench/intbench.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh index 4e0e5a62c..8fb1af6f0 100755 --- a/test/bench/intbench.sh +++ b/test/bench/intbench.sh @@ -201,7 +201,7 @@ function graph_variant { # } } END { - print "}\\datatime" ccomp (variant=="int32"? "int" : variant) + print "}\\datatime" (ccomp=="gcc-11" ? "gcc" : ccomp) (variant=="int32"? "int" : variant) print " " } ' $3 >> $4 From bb1743e30fd95bfd9ba36f94715b1d911990fbbf Mon Sep 17 00:00:00 2001 From: daan Date: Mon, 16 May 2022 10:23:58 -0700 Subject: [PATCH 039/233] update intbench --- test/bench/intbench.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh index 4e0e5a62c..2c9df9017 100644 --- a/test/bench/intbench.sh +++ b/test/bench/intbench.sh @@ -197,7 +197,7 @@ function graph_variant { # printf( "%i %0.3f %0.3f {\\absnormlabel{%0.3f}}\n", i++, $5, $6, $4 ); } else { - printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($5>4 ? 4 : $5), $6, $5); + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($5>2 ? 2 : $5), $6, $5); } } END { From 0ccc58f1fb3faf4a15fa6b0fc5ff9989cf2aaba0 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 18 May 2022 10:22:20 -0700 Subject: [PATCH 040/233] small edits --- kklib/include/kklib.h | 10 ------- kklib/include/kklib/integer.h | 50 +++++++++++++++++------------------ 2 files changed, 25 insertions(+), 35 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 7c9eab21d..c1f879ad4 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -13,16 +13,6 @@ #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks -// Integer arithmetic method -#define KK_INT_USE_OVF 1 // use limited tag bits and architecture overflow detection (only with gcc/clang) -#define KK_INT_USE_TAGOVF 2 // use tag bits (upfront check) and architecture overflow detection (only with gcc/clang) -#define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits -#define KK_INT_USE_RENO 4 // use range extended overflow arithmetic - -#ifndef KK_INT_ARITHMETIC -#define KK_INT_ARITHMETIC KK_INT_USE_SOFA -#endif - // Includes #define WIN32_LEAN_AND_MEAN // reduce windows includes #define _POSIX_C_SOURCE 200809L // make posix definitions visible diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index b3b5968b2..7dd825382 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -148,6 +148,18 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. -- Daan Leijen, 2020-2022. --------------------------------------------------------------------------------------------------*/ +// Integer arithmetic method +// note: we support these for now for experimentation, but we plan to converge on a single method +// in the future in order to simplify the code. +#define KK_INT_USE_OVF 1 // use limited tag bits and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_TAGOVF 2 // use tag bits (upfront check) and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits +#define KK_INT_USE_RENO 4 // use range extended overflow arithmetic + +#ifndef KK_INT_ARITHMETIC +#define KK_INT_ARITHMETIC KK_INT_USE_SOFA +#endif + #ifndef KK_INT_TAG #define KK_INT_TAG (1) #endif @@ -233,15 +245,16 @@ static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { //return ((_kk_integer_value(i)&1)==1 || (_kk_integer_value(j)&1)==1); } -#else +#else // KK_INT_USE_RENO #define KK_INT_MINPTR (KK_IF(1) << (KK_INTF_BITS - 2)) static inline bool kk_is_smallint(kk_integer_t i) { //return (_kk_integer_value(i) < KK_INT_MINPTR); //return (_kk_integer_value(i) <= KK_SMALLINT_MAX); - kk_intf_t x = _kk_integer_value(i); - return (x == (kk_smallint_t)x); + //kk_intf_t x = _kk_integer_value(i); + //return (x == (kk_smallint_t)x); //return ((kk_uintf_t)((x>>32)+1) <= 1); + return ((_kk_integer_value(i)>>(KK_INTF_BITS-2)) <= 0); } static inline bool kk_is_bigint(kk_integer_t i) { @@ -279,9 +292,16 @@ static inline bool kk_is_integer(kk_integer_t i) { || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i)) == KK_TAG_BIGINT)); } +#define KK_SMALLINT_MAX1 (KK_SMALLINT_MAX+1) static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); - return (kk_is_smallint(i) && kk_is_smallint(j)); + // return (kk_is_smallint(i) && kk_is_smallint(j)); + kk_intf_t x = _kk_integer_value(i); + kk_intf_t y = _kk_integer_value(j); + //return (((((kk_uintf_t)x+KK_SMALLINT_MAX+1)|((kk_uintf_t)y+KK_SMALLINT_MAX+1)) & KK_INT_MINPTR) != 0); + return ((x>>(KK_INTF_BITS-3))+(y>>(KK_INTF_BITS-3)) <= 0); + //kk_intf_t z = x + y; + //return (z == (int32_t)z); } #endif @@ -975,52 +995,32 @@ static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_conte } static inline bool kk_integer_lt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) < _kk_integer_value(y)); - #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) == -1); } static inline bool kk_integer_lt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) < _kk_integer_value(y)); - #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic(x, y, ctx) == -1); } static inline bool kk_integer_lte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); - #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) <= 0); } static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(y)); - #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) == 1); } static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(y)); - #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic(x, y, ctx) == 1); } static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO + #if 0 // KK_INT_ARITHMETIC == KK_INT_USE_RENO if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); #else if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) >= _kk_integer_value(y)); From 9d2eced74285fd24145a95df61f0850bbdeb81fc Mon Sep 17 00:00:00 2001 From: daan Date: Wed, 18 May 2022 22:48:57 -0700 Subject: [PATCH 041/233] initial code to maintain a dynamic context path --- kklib/include/kklib.h | 1 + src/Backend/C/FromCore.hs | 9 ++++ src/Common/NamePrim.hs | 2 + src/Compiler/Compile.hs | 2 +- src/Compiler/Options.hs | 3 ++ src/Core/CTail.hs | 103 ++++++++++++++++++++++++++++---------- 6 files changed, 93 insertions(+), 27 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index c1f879ad4..1094c16b1 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1367,5 +1367,6 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { } +#define kk_ctail_set_context_field(x,field,tp,as_tp) (as_tp(x)->_base._block.header._field_idx = (offsetof(tp,field)/KK_INTPTR_SIZE),x) #endif // include guard diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 82f6d1d2f..3f855be37 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1791,6 +1791,12 @@ genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conNa doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return (drop,text "(kk_box_t*)" <.> parens doc) +-- special: cfield-set-context +genAppNormal (Var cfieldSetContext _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldSetContext == nameCSetContextField + = do (decl,conVar) <- genVarBinding conExpr + let doc = genFieldSetContext conVar (readQualified conName) (readQualified fieldName) + return ([decl],doc) + -- add/sub small constant genAppNormal (Var add _) [arg, Lit (LitInt i)] | getName add == nameIntAdd && isSmallInt i -- arg + i = do (decls,argDocs) <- genInlineableExprs [arg] @@ -1854,6 +1860,9 @@ genFieldAddress :: TName -> Name -> Name -> Doc genFieldAddress conVar conName fieldName = parens (text "&" <.> conAsNameX (conName) <.> parens (ppName (getName conVar)) <.> text "->" <.> ppName (unqualify fieldName)) +genFieldSetContext :: TName -> Name -> Name -> Doc +genFieldSetContext conVar conName fieldName + = text "kk_ctail_set_context_field" <.> tupled [ppName (getName conVar), ppName (unqualify fieldName), text "struct" <+> ppName conName, conAsNameX conName] genAppSpecial :: Expr -> [Expr] -> Asm (Maybe Doc) genAppSpecial f args diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index be7e756c2..c74baae4c 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -78,6 +78,7 @@ module Common.NamePrim , nameCTailNil , nameCTailLink , nameCTailResolve + , nameCSetContextField -- * Constructors , nameTrue, nameFalse @@ -275,6 +276,7 @@ nameCFieldOf = cfieldName ".cfield-of" nameCTailNil = cfieldName ".ctail-nil" nameCTailLink = cfieldName ".ctail-link" nameCTailResolve = cfieldName ".ctail-resolve" +nameCSetContextField = cfieldName ".ctail-set-context-field" cfieldName name = coreTypesName name {-------------------------------------------------------------------------- diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 7869e77fb..1003a24a3 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -918,7 +918,7 @@ inferCheck loaded0 flags line coreImports program -- tail-call-modulo-cons optimization when (optctail flags) $ - ctailOptimize penv (platform flags) newtypes gamma (optctailInline flags) + ctailOptimize penv (platform flags) newtypes gamma (optctailInline flags) (optctailContext flags) -- transform effects to explicit monadic binding (and resolve .open calls) when (enableMon flags && not (isPrimitiveModule (Core.coreProgName coreProgram))) $ diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index b90ed590d..ada4d836a 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -176,6 +176,7 @@ data Flags , optInlineMax :: Int , optctail :: Bool , optctailInline :: Bool + , optctailContext :: Bool , parcReuse :: Bool , parcSpecialize :: Bool , parcReuseSpec :: Bool @@ -269,6 +270,7 @@ flagsNull 12 -- inlineMax True -- optctail False -- optctailInline + True -- optctailContext True -- parc reuse True -- parc specialize True -- parc reuse specialize @@ -378,6 +380,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , hide $ fflag ["optreusespec"] (\b f -> f{parcReuseSpec=b}) "enable reuse specialization" , hide $ fflag ["opttrmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" , hide $ fflag ["opttrmcinline"] (\b f -> f{optctailInline=b}) "enable trmc inlining (increases code size)" + , hide $ fflag ["opttrmcctx"] (\b f -> f{optctailContext=b}) "enable trmc context paths" , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" -- deprecated diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 30ad55f2b..80987b1a7 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -42,14 +42,14 @@ import Core.Pretty -------------------------------------------------------------------------- -- Reference count transformation -------------------------------------------------------------------------- -ctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> CorePhase () -ctailOptimize penv platform newtypes gamma ctailInline +ctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> CorePhase () +ctailOptimize penv platform newtypes gamma ctailInline useContextPath = liftCorePhaseUniq $ \uniq defs -> - runUnique uniq (uctailOptimize penv platform newtypes gamma ctailInline defs) + runUnique uniq (uctailOptimize penv platform newtypes gamma ctailInline useContextPath defs) -uctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> DefGroups -> Unique DefGroups -uctailOptimize penv platform newtypes gamma ctailInline defs - = ctailRun penv platform newtypes gamma ctailInline (ctailDefGroups True defs) +uctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> DefGroups -> Unique DefGroups +uctailOptimize penv platform newtypes gamma ctailInline useContextPath defs + = ctailRun penv platform newtypes gamma ctailInline useContextPath (ctailDefGroups True defs) -------------------------------------------------------------------------- -- Definition groups @@ -263,11 +263,13 @@ ctailExpr top expr Just slot -> do isMulti <- getIsMulti return (makeCTailResolve isMulti slot body) - handleConApp dname cname f fargs - = do let mkCons args = bindArgs args $ (\xs -> return ([],App f xs)) - mbExpr <- ctailTryArg dname cname Nothing mkCons (length fargs) (reverse fargs) + handleConApp dname cname fcon fargs + = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) + isMulti <- getIsMulti + useContextPath <- getUseContextPath + mbExpr <- ctailTryArg (not isMulti && useContextPath) dname cname Nothing mkCons (length fargs) (reverse fargs) case mbExpr of - Nothing -> tailResult (App f fargs) + Nothing -> tailResult (App fcon fargs) Just (defs,expr) -> return (makeLet defs expr) handleTailCall mkCall @@ -305,9 +307,9 @@ ctailGuard (Guard test expr) -- expects patAdded in depth-order -- See if the tailcall is inside a (nested) constructor application -------------------------------------------------------------------------- -ctailTryArg :: TName -> TName -> Maybe TName -> ([Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) -ctailTryArg dname cname mbC mkApp field [] = return Nothing -ctailTryArg dname cname mbC mkApp field (rarg:rargs) +ctailTryArg :: Bool -> TName -> TName -> Maybe TName -> ([Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) +ctailTryArg useCtxPath dname cname mbC mkApp field [] = return Nothing +ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) = case rarg of App f@(TypeApp (Var name info) targs) fargs | (dname == name) -> do expr <- ctailFoundArg cname mbC mkAppNew field @@ -321,20 +323,49 @@ ctailTryArg dname cname mbC mkApp field (rarg:rargs) -- recurse into other con App f@(TypeApp (Con cname2 _) _) fargs | tnamesMember dname (fv fargs) -- && all isTotal rargs -> do x <- uniqueTName (typeOf rarg) - ctailTryArg dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) + ctailTryArg useCtxPath dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) App f@(Con cname2 _) fargs | tnamesMember dname (fv fargs) -- && all isTotal rargs -> do x <- uniqueTName (typeOf rarg) - ctailTryArg dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) + ctailTryArg useCtxPath dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) - _ -> if (isTotal rarg) then ctailTryArg dname cname mbC (\args -> mkApp (args ++ [rarg])) (field-1) rargs + _ -> if (isTotal rarg) then ctailTryArg useCtxPath dname cname mbC (\args -> mkApp (args ++ [rarg])) (field-1) rargs else return Nothing where - mkAppNew = (\args -> mkApp (reverse rargs ++ args)) - mkAppNested x f - = (\args -> do (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp (xs ++ [Var x InfoNone]) - return ([DefNonRec (makeTDef x (App f args))]++defs, expr)) - + -- create a tail call + mkAppNew + = \args -> do (defs,cexpr) <- mkApp (reverse rargs ++ args) + if not useCtxPath then return (defs,cexpr) + else do setfld <- setContextFieldExpr cname field + x <- uniqueTName (typeOf cexpr) + y <- uniqueTName (typeOf cexpr) + let cexprdef = DefNonRec (makeTDef y cexpr) + let setdef = DefNonRec (makeTDef x (setfld y)) + return (defs ++ [cexprdef,setdef], (Var x InfoNone)) + + + -- create the constructor context (ending in a hole) + mkAppNested :: TName -> Expr -> ([Expr] -> CTail ([DefGroup],Expr)) + mkAppNested x fcon + = \args -> do (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp (xs ++ [Var x InfoNone]) + if not useCtxPath + then do let condef = DefNonRec (makeTDef x (App fcon args)) + return ([condef] ++ defs, expr) + else do setfld <- setContextFieldExpr cname field + y <- uniqueTName (typeOf x) + let condef = DefNonRec (makeTDef y (App fcon args)) + let setdef = DefNonRec (makeTDef x (setfld y)) + return ([condef,setdef] ++ defs, expr) + + +setContextFieldExpr cname field + = do fieldInfo <- getFieldName cname field + case fieldInfo of + Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 + Right (_,fieldName) -> + return (\parent -> makeCSetContextField (Var parent InfoNone) cname fieldName) + + -------------------------------------------------------------------------- -- Found a tail call inside a constructor application @@ -375,6 +406,7 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs -- Primitives -------------------------------------------------------------------------- +-- Polymorphic hole makeCFieldHole :: Type -> Expr makeCFieldHole tp = App (TypeApp (Var (TName nameCFieldHole funType) (InfoExternal [])) [tp]) [] @@ -383,6 +415,7 @@ makeCFieldHole tp a = TypeVar 0 kindStar Bound +-- Initial empty context (@ctx hole) makeCTailNil :: Type -> Expr makeCTailNil tp = App (TypeApp (Var (TName nameCTailNil funType) @@ -394,6 +427,7 @@ makeCTailNil tp a = TypeVar 0 kindStar Bound +-- The adress of a field in a constructor (for context holes) makeCFieldOf :: TName -> TName -> Name -> Type -> Expr makeCFieldOf objName conName fieldName tp = App (TypeApp (Var (TName nameCFieldOf funType) (InfoExternal [])) [tp]) @@ -404,6 +438,7 @@ makeCFieldOf objName conName fieldName tp a = TypeVar 0 kindStar Bound +-- Compose two contexts makeCTailLink :: TName -> TName -> TName -> TName -> Name -> Type -> Expr makeCTailLink slot resName objName conName fieldName tp = let fieldOf = makeCFieldOf objName conName fieldName tp @@ -419,6 +454,7 @@ makeCTailLink slot resName objName conName fieldName tp a = TypeVar 0 kindStar Bound +-- Apply a context to its final value. makeCTailResolve :: Bool -> TName -> Expr -> Expr makeCTailResolve True slot expr -- slot `a -> a` is an accumulating function; apply to resolve = App (Var slot InfoNone) [expr] @@ -435,6 +471,16 @@ makeCTailResolve False slot expr -- slot is a `ctail` a = TypeVar (-1) kindStar Bound +-- Set the index of the field in a constructor to follow the path to the hole at runtime. +makeCSetContextField :: Expr -> TName -> Name -> Expr +makeCSetContextField obj conName fieldName + = App (Var (TName nameCSetContextField funType) (InfoExternal [(Default,".cfield-set-context(#1,#2,#3)")])) + [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] + where + tp = typeOf obj + funType = (TFun [(nameNil,tp),(nameNil,typeString),(nameNil,typeString)] typeTotal tp) + + -------------------------------------------------------------------------- -- Utilities for readability -------------------------------------------------------------------------- @@ -469,7 +515,8 @@ data Env = Env { currentDef :: [Def], ctailInline :: Bool, ctailName :: TName, ctailSlot :: Maybe TName, - isMulti :: Bool + isMulti :: Bool, + useContextPath :: Bool } data CTailState = CTailState { uniq :: Int } @@ -495,10 +542,10 @@ updateSt = modify getSt :: CTail CTailState getSt = get -ctailRun :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> CTail a -> Unique a -ctailRun penv platform newtypes gamma ctailInline (CTail action) +ctailRun :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> CTail a -> Unique a +ctailRun penv platform newtypes gamma ctailInline useContextPath (CTail action) = withUnique $ \u -> - let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True + let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True useContextPath st = CTailState u (val, st') = runState (runReaderT action env) st in (val, uniq st') @@ -524,6 +571,10 @@ getIsMulti :: CTail Bool getIsMulti = isMulti <$> getEnv +getUseContextPath :: CTail Bool +getUseContextPath + = useContextPath <$> getEnv + getFieldName :: TName -> Int -> CTail (Either String (Expr,Name)) getFieldName cname field = do env <- getEnv @@ -531,7 +582,7 @@ getFieldName cname field Just dataInfo -> do let (dataRepr,_) = getDataRepr dataInfo if (dataReprIsValue dataRepr) - then return (Left ("cannot optimize modulo-cons tail-call over a value type (" ++ show (getName cname) ++ ")")) + then return (Left ("cannot optimize modulo-cons tail-call through a value type (" ++ show (getName cname) ++ ")")) else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of [con] -> case drop (field - 1) (conInfoParams con) of ((fname,ftp):_) -> return $ Right (Con cname (getConRepr dataInfo con), fname) From add8e8c12d7848238c8b93446d84bb8bcef57c74 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 10:53:27 -0700 Subject: [PATCH 042/233] initial working context paths --- kklib/include/kklib.h | 6 +++++ kklib/src/refcount.c | 41 +++++++++++++++++++++++++++++++ lib/std/core/types-ctail-inline.h | 36 ++++++++++++++++++++++----- src/Compiler/Options.hs | 1 + src/Core/CTail.hs | 11 ++++++--- test/cgen/ctail3b.kk | 4 +-- test/cgen/ctail5.kk | 36 ++++++++++++--------------- 7 files changed, 103 insertions(+), 32 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 1094c16b1..bb7fc4323 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -304,6 +304,11 @@ static inline void kk_block_field_set(kk_block_t* b, kk_ssize_t index, kk_box_t bf->fields[index] = v; } +static inline kk_decl_pure kk_box_t* kk_block_field_address(kk_block_t* b, kk_ssize_t index) { + kk_block_fields_t* bf = (kk_block_fields_t*)b; // must overlap with datatypes with scanned fields. + return &bf->fields[index]; +} + #if (KK_INTPTR_SIZE==8) #define KK_BLOCK_INVALID KK_UP(0xDFDFDFDFDFDFDFDF) #else @@ -1367,6 +1372,7 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { } +kk_decl_export kk_box_t kk_ctail_context_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); #define kk_ctail_set_context_field(x,field,tp,as_tp) (as_tp(x)->_base._block.header._field_idx = (offsetof(tp,field)/KK_INTPTR_SIZE),x) #endif // include guard diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 655a8ad99..d0b3c1877 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -578,3 +578,44 @@ kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx) { kk_block_mark_shared_recx(kk_ptr_unbox(b), ctx); } } + +static kk_ssize_t kk_block_full_size(kk_block_t* b, kk_context_t* ctx) { + kk_unused(ctx); + return kk_to_ssize_t(mi_usable_size(b)); +} + +static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { + kk_ssize_t size = kk_block_full_size(b,ctx); + kk_block_t* c = (kk_block_t*)kk_malloc_small(size,ctx); + memcpy(c,b,size); + kk_block_refcount_set(c,0); + return c; +} + +kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res))); + kk_box_t cres; + kk_box_t* parent = NULL; + kk_block_t* c; + kk_box_t cur = res; + do { + kk_block_t* b = kk_ptr_unbox(cur); + const kk_ssize_t field = kk_block_field_idx(b) - 1; + kk_assert_internal(field >= 0) + c = kk_block_alloc_copy(b,ctx); + if (parent == NULL) { cres = kk_ptr_box(c); } + else { *parent = kk_ptr_box(c); } + for( kk_ssize_t i = 0; i < kk_block_scan_fsize(b); i++) { + if (i != field) { + kk_box_dup(kk_block_field(c, i)); + } + } + parent = kk_block_field_address(c,field); + cur = *parent; + } + while (kk_box_is_ptr(cur)); + kk_assert_internal(parent != NULL); + *parent = child; + kk_box_drop(res,ctx); + return cres; +} \ No newline at end of file diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index f4c195e89..caa4cbcf3 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -16,15 +16,39 @@ static inline kk_box_t kk_ctail_hole(void) { return kk_intf_box(0); } -static inline kk_std_core_types__ctail kk_ctail_nil(void) { - return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, NULL ); +static inline kk_std_core_types__ctail kk_ctail_nil(kk_context_t* ctx) { + return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, ctx); } -static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t res, kk_box_t* field ) { - return kk_std_core_types__new_CTail( (kk_likely(acc.hole != NULL) ? (*(acc.hole) = res, acc.res) : res ), field, NULL ); +// apply a context to a child value +static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t child, kk_context_t* ctx ) { + #if !defined(KK_CTAIL_NO_CONTEXT_PATH) + // note: written like this for best codegen; be careful when rewriting. + if (kk_likely(acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res)))) { + *(acc.hole) = child; // in-place update the hole with the child + return acc.res; + } + else if (acc.hole == NULL) { + return child; + } + else { + return kk_ctail_context_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child + } + #else + if (kk_likely(acc.hole != NULL)) { + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); + *(acc.hole) = child; + return acc.res; + } + else { + return child; + } + #endif } -static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t res ) { - return (kk_likely(acc.hole != NULL) ? (*(acc.hole) = res, acc.res) : res ); +// compose a context to a new one +static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, kk_context_t* ctx ) { + return kk_std_core_types__new_CTail( kk_ctail_resolve(acc,child,ctx), field, ctx ); } + diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index ada4d836a..0a7357296 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -662,6 +662,7 @@ processOptions flags0 opts cdefs = ccompDefs flags ++ if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))] ++ if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")] + ++ if optctailContext flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")] -- vcpkg -- (vcpkgRoot,vcpkg) <- vcpkgFindRoot (vcpkgRoot flags) diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 80987b1a7..46b9ab99f 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -93,8 +93,9 @@ ctailDef topLevel def cdefExpr <- withContext ctailTName False (Just ctailTSlot) $ ctailExpr True (makeCDefExpr ctailTSlot (defExpr def)) + useContextPath <- getUseContextPath let cdef = def{ defName = ctailName, defType = ctailType, defExpr = cdefExpr } - needsMulti = not (effectIsAffine teff) + needsMulti = not (useContextPath || effectIsAffine teff) ctailMultiSlotType = TFun [(nameNil,tres)] typeTotal tres ctailMultiName = makeHiddenName "ctailm" (defName def) ctailMultiSlot = newHiddenName "accm" @@ -420,7 +421,7 @@ makeCTailNil :: Type -> Expr makeCTailNil tp = App (TypeApp (Var (TName nameCTailNil funType) -- (InfoArity 1 0) - (InfoExternal [(C CDefault,"kk_ctail_nil()"),(JS JsDefault,"$std_core_types._ctail_nil()")]) + (InfoExternal [(C CDefault,"kk_ctail_nil(kk_context())"),(JS JsDefault,"$std_core_types._ctail_nil()")]) ) [tp]) [] where funType = TForall [a] [] (TFun [] typeTotal (TApp typeCTail [TVar a])) @@ -444,7 +445,8 @@ makeCTailLink slot resName objName conName fieldName tp = let fieldOf = makeCFieldOf objName conName fieldName tp in App (TypeApp (Var (TName nameCTailLink funType) -- (InfoArity 1 3) - (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3)"),(JS JsDefault,"$std_core_types._ctail_link(#1,#2,#3)")]) + (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3,kk_context())"), + (JS JsDefault,"$std_core_types._ctail_link(#1,#2,#3)")]) ) [tp]) [Var slot InfoNone, Var resName InfoNone, fieldOf] where @@ -461,7 +463,8 @@ makeCTailResolve True slot expr -- slot `a -> a` is an accumulating function; makeCTailResolve False slot expr -- slot is a `ctail` = App (TypeApp (Var (TName nameCTailResolve funType) -- (InfoArity 1 2) - (InfoExternal [(Default,"kk_ctail_resolve(#1,#2)"),(JS JsDefault,"$std_core_types._ctail_resolve(#1,#2)")]) + (InfoExternal [(C CDefault,"kk_ctail_resolve(#1,#2,kk_context())"), + (JS JsDefault,"$std_core_types._ctail_resolve(#1,#2)")]) ) [tp]) [Var slot InfoNone, expr] where diff --git a/test/cgen/ctail3b.kk b/test/cgen/ctail3b.kk index 4a6ecba92..5f4b4fea9 100644 --- a/test/cgen/ctail3b.kk +++ b/test/cgen/ctail3b.kk @@ -11,6 +11,6 @@ fun mapx( xs : list, f : a -> e b ) : e list { } fun main() { - with fun out(s:string) { if (s=="9") throw(s); println(s) } - list(1,10).mapx(fn(i:int){ if (i.is-odd) i.show.out; i+1 }).sum.println + with fun out(s:string) { if s=="9" then throw(s); println(s) } + list(1,10).mapx(fn(i:int){ if i.is-odd then i.show.out; i+1 }).sum.println } diff --git a/test/cgen/ctail5.kk b/test/cgen/ctail5.kk index ba7ad17d0..e98d673c6 100644 --- a/test/cgen/ctail5.kk +++ b/test/cgen/ctail5.kk @@ -3,32 +3,28 @@ effect nondet { ctl fail() : a } -fun knapsack(w : int, vs : list ) : list { +fun knapsack(w : int, vs : list ) : list if (w < 0) then fail() elif (w == 0) then [] - else { + else val v = select(vs) Cons(v,knapsack(w - v, vs)) - } -} - -fun select(xs) { - match(xs) { + +fun select(xs) + match xs Nil -> fail() - Cons(x,xx) -> if (flip()) then x else select(xx) - } -} + Cons(x,xx) -> if flip() then x else select(xx) + +val solutions = handler + return(x) [x] + ctl fail() [] + ctl flip() resume(True) ++ resume(False) -val solutions = handler { - return x -> [x] - ctl fail() -> [] - ctl flip() -> resume(True) + resume(False) -} -fun show( xss : list> ) : string { - xss.show-list(fn(xs) { xs.show-list(core/show) } ) -} +fun show( xss : list> ) : string + xss.show-list( fn(xs) xs.show-list(core/show) ) + -fun main() { +fun main() solutions{ knapsack(3,[3,2,1]) } -} + From 5b2c61b7284edb966dc881a463a000fcbf1c633b Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 19 May 2022 12:52:32 -0700 Subject: [PATCH 043/233] better setfield macro --- kklib/include/kklib.h | 15 +++++++++++++-- kklib/src/refcount.c | 10 +--------- src/Backend/C/FromCore.hs | 4 +++- stack.yaml | 3 ++- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index bb7fc4323..4f2ac9fe0 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -309,6 +309,15 @@ static inline kk_decl_pure kk_box_t* kk_block_field_address(kk_block_t* b, kk_ss return &bf->fields[index]; } +static inline kk_decl_pure uint8_t kk_block_field_idx(const kk_block_t* b) { + return b->header._field_idx; +} + +static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { + kk_assert_internal(idx <= b->header.scan_fsize); // allow +1 for trmc context paths + b->header._field_idx = idx; +} + #if (KK_INTPTR_SIZE==8) #define KK_BLOCK_INVALID KK_UP(0xDFDFDFDFDFDFDFDF) #else @@ -813,7 +822,7 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define kk_basetype_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_block),n,ctx)) #define kk_basetype_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) #define kk_basetype_reuse(v) (&((v)->_block)) - +#define kk_basetype_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_block),x)) #define kk_basetype_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) #define kk_basetype_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) #define kk_basetype_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) @@ -824,6 +833,7 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define kk_constructor_dup_as(tp,v) (kk_basetype_dup_as(tp, &((v)->_base))) #define kk_constructor_drop(v,ctx) (kk_basetype_drop(&((v)->_base),ctx)) #define kk_constructor_dropn_reuse(v,n,ctx) (kk_basetype_dropn_reuse(&((v)->_base),n,ctx)) +#define kk_constructor_field_idx_set(v,x) (kk_basetype_field_idx_set(&((v)->_base),x)) #define kk_value_dup(v) (v) #define kk_value_drop(v,ctx) (void) @@ -1373,6 +1383,7 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { kk_decl_export kk_box_t kk_ctail_context_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); -#define kk_ctail_set_context_field(x,field,tp,as_tp) (as_tp(x)->_base._block.header._field_idx = (offsetof(tp,field)/KK_INTPTR_SIZE),x) +#define kk_ctail_set_context_field(as_tp,x,field_offset) \ + (kk_constructor_field_idx_set( as_tp(x), 1 + (field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)), x) #endif // include guard diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index d0b3c1877..e3ae9ebff 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -233,14 +233,6 @@ static bool kk_block_decref_no_free(kk_block_t* b) { // (and it is faster than a recursive version so we only have a stackless free) //----------------------------------------------------------------------------------------- -static inline uint8_t kk_decl_pure kk_block_field_idx(const kk_block_t* b) { - return b->header._field_idx; -} - -static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { - b->header._field_idx = idx; -} - // Check if a field `i` in a block `b` should be freed, i.e. it is heap allocated with a refcount of 0. // Optimizes by already freeing leaf blocks that are heap allocated but have no scan fields. static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) @@ -601,7 +593,7 @@ kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_compose( kk_box_t res, do { kk_block_t* b = kk_ptr_unbox(cur); const kk_ssize_t field = kk_block_field_idx(b) - 1; - kk_assert_internal(field >= 0) + kk_assert_internal(field >= 0); c = kk_block_alloc_copy(b,ctx); if (parent == NULL) { cres = kk_ptr_box(c); } else { *parent = kk_ptr_box(c); } diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 3f855be37..4ddf9ed50 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1862,7 +1862,9 @@ genFieldAddress conVar conName fieldName genFieldSetContext :: TName -> Name -> Name -> Doc genFieldSetContext conVar conName fieldName - = text "kk_ctail_set_context_field" <.> tupled [ppName (getName conVar), ppName (unqualify fieldName), text "struct" <+> ppName conName, conAsNameX conName] + = text "kk_ctail_set_context_field" <.> + tupled [conAsNameX conName, ppName (getName conVar), + text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] genAppSpecial :: Expr -> [Expr] -> Asm (Maybe Doc) genAppSpecial f args diff --git a/stack.yaml b/stack.yaml index 991492511..70fad5f80 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,8 @@ # $ cabal new-run koka # See also . -resolver: lts-18.21 # ghc 8.10.7 -- works for M1 +# resolver: lts-19.7 # ghc 9.0.2 +resolver: lts-18.28 # ghc 8.10.7 -- works for M1 # resolver: lts-18.6 # ghc 8.10.4 # resolver: lts-14.27 # ghc 8.6.5 # resolver: lts-9.21 # ghc 8.0.2 -- works for older linux-arm64 From 54c5afffedc55e0ef3be0acb21902bb280404792 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 12:53:34 -0700 Subject: [PATCH 044/233] add tests for ctail --- test/cgen/ctail2a.kk | 11 +++++++++++ test/cgen/ctail9.kk | 16 ++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 test/cgen/ctail2a.kk create mode 100644 test/cgen/ctail9.kk diff --git a/test/cgen/ctail2a.kk b/test/cgen/ctail2a.kk new file mode 100644 index 000000000..90d999777 --- /dev/null +++ b/test/cgen/ctail2a.kk @@ -0,0 +1,11 @@ + +fun mapx( xs : list, f : a -> total b ) : total list { + match(xs) { + Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Nil -> Nil + } +} + +fun main() { + list(1,10).mapx(fn(i){ i+1 }).sum.println +} diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk new file mode 100644 index 000000000..c25256703 --- /dev/null +++ b/test/cgen/ctail9.kk @@ -0,0 +1,16 @@ + +fun mapx( xs : list, f : a -> e b ) : e list { + match(xs) { + Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Nil -> Nil + } +} + + +fun test(n : int) { + val xs = list(1,n) + val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) + acc + xs.mapx(fn(x){ x+1 }).sum + println("total: " ++ x.show) +} + From 7a2649d3595f654468bb1880ad15f7c955e193fd Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 18:08:23 -0700 Subject: [PATCH 045/233] add affine effect optimization --- lib/std/core/types-ctail-inline.h | 8 +++--- src/Core/CTail.hs | 46 +++++++++++++++++++------------ 2 files changed, 32 insertions(+), 22 deletions(-) diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index caa4cbcf3..5bf7ad87c 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -21,10 +21,10 @@ static inline kk_std_core_types__ctail kk_ctail_nil(kk_context_t* ctx) { } // apply a context to a child value -static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t child, kk_context_t* ctx ) { +static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { #if !defined(KK_CTAIL_NO_CONTEXT_PATH) // note: written like this for best codegen; be careful when rewriting. - if (kk_likely(acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res)))) { + if (kk_likely(acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res))))) { *(acc.hole) = child; // in-place update the hole with the child return acc.res; } @@ -47,8 +47,8 @@ static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t } // compose a context to a new one -static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, kk_context_t* ctx ) { - return kk_std_core_types__new_CTail( kk_ctail_resolve(acc,child,ctx), field, ctx ); +static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { + return kk_std_core_types__new_CTail( kk_ctail_resolve(acc,child,is_linear,ctx), field, ctx ); } diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 46b9ab99f..3a13d2178 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -90,12 +90,13 @@ ctailDef topLevel def ctailTName= TName ctailName ctailType ctailTSlot= TName ctailSlot ctailSlotType - cdefExpr <- withContext ctailTName False (Just ctailTSlot) $ + let alwaysAffine = effectIsAffine teff + cdefExpr <- withContext ctailTName False {-isMulti-} alwaysAffine (Just ctailTSlot) $ ctailExpr True (makeCDefExpr ctailTSlot (defExpr def)) useContextPath <- getUseContextPath let cdef = def{ defName = ctailName, defType = ctailType, defExpr = cdefExpr } - needsMulti = not (useContextPath || effectIsAffine teff) + needsMulti = not (useContextPath || alwaysAffine) ctailMultiSlotType = TFun [(nameNil,tres)] typeTotal tres ctailMultiName = makeHiddenName "ctailm" (defName def) ctailMultiSlot = newHiddenName "accm" @@ -104,7 +105,7 @@ ctailDef topLevel def ctailMultiTSlot = TName ctailMultiSlot ctailMultiSlotType ctailMultiVar = Var ctailMultiTName (InfoArity (length tforall) (length targs + 1)) - wrapExpr <- withContext ctailTName False Nothing $ + wrapExpr <- withContext ctailTName False alwaysAffine Nothing $ do ctailWrapper ctailTSlot (if needsMulti then Just ctailMultiVar else Nothing) (defExpr def) @@ -114,7 +115,7 @@ ctailDef topLevel def then -- for sure, each op resumes at most once return [ DefRec [cdef, def{defExpr = wrapExpr }] ] else -- some ops may resume more than once; specialize for those - do cdefMultiExpr <- withContext ctailMultiTName True (Just ctailMultiTSlot) $ + do cdefMultiExpr <- withContext ctailMultiTName True {-isMulti-} alwaysAffine (Just ctailMultiTSlot) $ ctailExpr True (makeCDefExpr ctailMultiTSlot (defExpr def)) let cdefMulti = def{ defName = ctailMultiName, defType = ctailMultiType, defExpr = cdefMultiExpr } return $ [ DefRec [cdef, cdefMulti, def{defExpr = wrapExpr} ] ] @@ -262,7 +263,8 @@ ctailExpr top expr case mbSlot of Nothing -> return body Just slot -> do isMulti <- getIsMulti - return (makeCTailResolve isMulti slot body) + alwaysAffine <- getIsAlwaysAffine + return (makeCTailResolve isMulti alwaysAffine slot body) handleConApp dname cname fcon fargs = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) @@ -397,7 +399,8 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs hole = makeCFieldHole resTp (defs,cons) <- mkConsApp [hole] consName <- uniqueTName (typeOf cons) - let link = makeCTailLink slot consName (maybe consName id mbC) cname fieldName resTp + alwaysAffine <- getIsAlwaysAffine + let link = makeCTailLink slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine ctailCall = mkTailApp ctailVar link -- App ctailVar (fargs ++ [link]) return $ (defs ++ [DefNonRec (makeTDef consName cons)] ,ctailCall) @@ -440,16 +443,17 @@ makeCFieldOf objName conName fieldName tp -- Compose two contexts -makeCTailLink :: TName -> TName -> TName -> TName -> Name -> Type -> Expr -makeCTailLink slot resName objName conName fieldName tp +makeCTailLink :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr +makeCTailLink slot resName objName conName fieldName tp alwaysAffine = let fieldOf = makeCFieldOf objName conName fieldName tp in App (TypeApp (Var (TName nameCTailLink funType) -- (InfoArity 1 3) - (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3,kk_context())"), + (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3," ++ affine ++ ",kk_context())"), (JS JsDefault,"$std_core_types._ctail_link(#1,#2,#3)")]) ) [tp]) [Var slot InfoNone, Var resName InfoNone, fieldOf] where + affine = if alwaysAffine then "true" else "false" funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]), (nameNil,TVar a), (nameNil,TApp typeCField [TVar a])] typeTotal (TApp typeCTail [TVar a])) @@ -457,17 +461,18 @@ makeCTailLink slot resName objName conName fieldName tp -- Apply a context to its final value. -makeCTailResolve :: Bool -> TName -> Expr -> Expr -makeCTailResolve True slot expr -- slot `a -> a` is an accumulating function; apply to resolve +makeCTailResolve :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr +makeCTailResolve True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve = App (Var slot InfoNone) [expr] -makeCTailResolve False slot expr -- slot is a `ctail` +makeCTailResolve False alwaysAffine slot expr -- slot is a `ctail` = App (TypeApp (Var (TName nameCTailResolve funType) -- (InfoArity 1 2) - (InfoExternal [(C CDefault,"kk_ctail_resolve(#1,#2,kk_context())"), + (InfoExternal [(C CDefault,"kk_ctail_resolve(#1,#2," ++ affine ++ ",kk_context())"), (JS JsDefault,"$std_core_types._ctail_resolve(#1,#2)")]) ) [tp]) [Var slot InfoNone, expr] where + affine = if alwaysAffine then "true" else "false" tp = case typeOf slot of TApp _ [t] -> t funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]),(nameNil,TVar a)] typeTotal (TVar a)) @@ -519,7 +524,8 @@ data Env = Env { currentDef :: [Def], ctailName :: TName, ctailSlot :: Maybe TName, isMulti :: Bool, - useContextPath :: Bool + useContextPath :: Bool, + alwaysAffine :: Bool } data CTailState = CTailState { uniq :: Int } @@ -548,15 +554,15 @@ getSt = get ctailRun :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> CTail a -> Unique a ctailRun penv platform newtypes gamma ctailInline useContextPath (CTail action) = withUnique $ \u -> - let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True useContextPath + let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True useContextPath False st = CTailState u (val, st') = runState (runReaderT action env) st in (val, uniq st') -withContext :: TName -> Bool -> Maybe TName -> CTail a -> CTail a -withContext name isMulti mbSlot action - = withEnv (\env -> env{ ctailName = name, ctailSlot = mbSlot, isMulti = isMulti }) action +withContext :: TName -> Bool -> Bool -> Maybe TName -> CTail a -> CTail a +withContext name isMulti alwaysAffine mbSlot action + = withEnv (\env -> env{ ctailName = name, ctailSlot = mbSlot, isMulti = isMulti, alwaysAffine = alwaysAffine }) action getCTailFun :: CTail Expr getCTailFun @@ -578,6 +584,10 @@ getUseContextPath :: CTail Bool getUseContextPath = useContextPath <$> getEnv +getIsAlwaysAffine :: CTail Bool +getIsAlwaysAffine + = alwaysAffine <$> getEnv + getFieldName :: TName -> Int -> CTail (Either String (Expr,Name)) getFieldName cname field = do env <- getEnv From 4c9200b7f421f19d80cfc4c3cc627932d6c96bd7 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 18:31:43 -0700 Subject: [PATCH 046/233] optimize set context paths for affine effects --- kklib/include/kklib/box.h | 16 +++++++++++++++- kklib/src/box.c | 11 +---------- src/Core/CTail.hs | 4 +++- test/cgen/ctail5a.kk | 36 ++++++++++++++++++++++++++++++++++++ 4 files changed, 55 insertions(+), 12 deletions(-) create mode 100644 test/cgen/ctail5a.kk diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 1a71ca36b..ca83e36a3 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -393,7 +393,21 @@ typedef struct kk_cfunptr_s { #define kk_cfun_ptr_box(f,ctx) kk_cfun_ptr_boxx((kk_cfun_ptr_t)f, ctx) kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx); -kk_decl_export kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b); +// kk_decl_export kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b); + +// inline as it is used for unboxing (higher-order) function pointers. +// if we can guarantee for those function addresses to be always aligned we +// can perhaps optimize this further (without needing a check)? +static inline kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b) { // never drop; only used from function call + if (kk_likely(kk_box_is_value(b))) { + return (kk_cfun_ptr_t)(kk_uintf_unbox(b)); + } + else { + kk_cfunptr_t fp = kk_basetype_unbox_as_assert(kk_cfunptr_t, b, KK_TAG_CFUNPTR); + kk_cfun_ptr_t f = fp->cfunptr; + return f; + } +} diff --git a/kklib/src/box.c b/kklib/src/box.c index 3407a0ec9..c9ddb9fbe 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -229,16 +229,7 @@ kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx) { } } -kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b) { // never drop; only used from function call - if (kk_likely(kk_box_is_value(b))) { - return (kk_cfun_ptr_t)(kk_uintf_unbox(b)); - } - else { - kk_cfunptr_t fp = kk_basetype_unbox_as_assert(kk_cfunptr_t, b, KK_TAG_CFUNPTR); - kk_cfun_ptr_t f = fp->cfunptr; - return f; - } -} + /*---------------------------------------------------------------- Maybe type support diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 3a13d2178..073b5ba7b 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -270,7 +270,9 @@ ctailExpr top expr = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) isMulti <- getIsMulti useContextPath <- getUseContextPath - mbExpr <- ctailTryArg (not isMulti && useContextPath) dname cname Nothing mkCons (length fargs) (reverse fargs) + alwaysAffine <- getIsAlwaysAffine + let useCtx = not isMulti && useContextPath && not alwaysAffine + mbExpr <- ctailTryArg useCtx dname cname Nothing mkCons (length fargs) (reverse fargs) case mbExpr of Nothing -> tailResult (App fcon fargs) Just (defs,expr) -> return (makeLet defs expr) diff --git a/test/cgen/ctail5a.kk b/test/cgen/ctail5a.kk new file mode 100644 index 000000000..384da7f89 --- /dev/null +++ b/test/cgen/ctail5a.kk @@ -0,0 +1,36 @@ +// non deteministic TRMC over binary trees +// this tests the context copying code. +effect nondet + ctl flip() : bool + ctl fail() : a + +type tree + Bin(l:tree, r:tree) + Tip(value:int) + +fun tmap( t : tree, f : int -> e int ) : e tree + match t + Bin(l,r) -> Bin(tmap(l,f),tmap(r,f)) + Tip(i) -> Tip(f(i)) + + +fun tshow( t : tree ) : string + match t + Bin(l,r) -> "Bin(" ++ l.tshow ++ "," ++ r.tshow ++ ")" + Tip(i) -> "Tip(" ++ i.show ++ ")" + +fun incs( t : tree ) : nondet tree + t.tmap fn(i) + if flip() then i + 1 else i - 1 + + +val solutions = handler + return(x) [x] + ctl fail() [] + ctl flip() resume(True) ++ resume(False) + +fun main() + val t = Bin(Bin(Tip(1),Tip(2)),Bin(Tip(3),Tip(4))) + val ts = solutions{ incs(t) } + ts.show-list(tshow).println + From ad755f1c32acb0989bbdcfde072487c14e9c4b82 Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 19 May 2022 20:25:46 -0700 Subject: [PATCH 047/233] add test file for specialization with name capture --- src/Compiler/Compile.hs | 4 ++-- test/cgen/spec1.kk | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 test/cgen/spec1.kk diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 1003a24a3..d055519bd 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -897,9 +897,9 @@ inferCheck loaded0 flags line coreImports program when (optSpecialize flags && not (isPrimitiveModule (Core.coreProgName coreProgram))) $ do -- simplifyDupN - -- traceDefGroups "beforespec" + traceDefGroups "beforespec" specialize (inlinesExtends specializeDefs (loadedInlines loaded)) penv - -- traceDefGroups "specialized" + traceDefGroups "specialized" simplifyDupN -- traceDefGroups "simplified" -- lifting remaining recursive functions to top level (must be after specialize as that can generate local recursive definitions) diff --git a/test/cgen/spec1.kk b/test/cgen/spec1.kk new file mode 100644 index 000000000..5fa3d5217 --- /dev/null +++ b/test/cgen/spec1.kk @@ -0,0 +1,9 @@ +fun test-many() + var i := 0 + for(1,10000000) fn(j) + i := i + 1 + println(i) + + +fun main() + test-many() From b3a9549fc10290a53c3e5ff74e3aa9d30e84531d Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 21:12:15 -0700 Subject: [PATCH 048/233] fix renaming in specialization pass --- src/Common/Unique.hs | 7 +++++- src/Compiler/Compile.hs | 4 ++-- src/Core/CTail.hs | 11 +++++++-- src/Core/Specialize.hs | 11 ++++++--- src/Core/Uniquefy.hs | 49 ++++++++++++++++++++++++++++++++--------- 5 files changed, 63 insertions(+), 19 deletions(-) diff --git a/src/Common/Unique.hs b/src/Common/Unique.hs index cdf8cf366..6a8e26e2f 100644 --- a/src/Common/Unique.hs +++ b/src/Common/Unique.hs @@ -10,7 +10,7 @@ -} ----------------------------------------------------------------------------- module Common.Unique( -- * Unique - HasUnique(updateUnique,setUnique,unique,uniques,uniqueId,uniqueIds,uniqueName) + HasUnique(updateUnique,setUnique,unique,uniques,uniqueId,uniqueIds,uniqueName,uniqueNameFrom) -- ** Instances , Unique, runUnique, runUniqueWith, liftUnique, withUnique , UniqueT, runUniqueT @@ -36,6 +36,7 @@ class (Monad m, Functor m) => HasUnique m where uniqueId :: String -> m Id uniqueIds :: String -> Int -> m [Id] uniqueName :: String -> m Name + uniqueNameFrom :: Name -> m Name -- getUnique -- = updateUnique id @@ -61,6 +62,10 @@ class (Monad m, Functor m) => HasUnique m where = do i <- unique return (newHiddenName (baseName ++ "." ++ show i)) + uniqueNameFrom baseName + = do i <- unique + return (toUniqueName i baseName) + {-------------------------------------------------------------------------- Helper instance for unique variables diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index d055519bd..1003a24a3 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -897,9 +897,9 @@ inferCheck loaded0 flags line coreImports program when (optSpecialize flags && not (isPrimitiveModule (Core.coreProgName coreProgram))) $ do -- simplifyDupN - traceDefGroups "beforespec" + -- traceDefGroups "beforespec" specialize (inlinesExtends specializeDefs (loadedInlines loaded)) penv - traceDefGroups "specialized" + -- traceDefGroups "specialized" simplifyDupN -- traceDefGroups "simplified" -- lifting remaining recursive functions to top level (must be after specialize as that can generate local recursive definitions) diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 073b5ba7b..b79c3aa55 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -69,11 +69,18 @@ ctailDefGroup topLevel dg _ -> return [dg] where log - | DefRec [def] <- dg = "ctailDefGroup: " ++ show (defName def) ++ " " ++ (if (hasCTailCall (defTName def) True (defExpr def)) then "IS " else "is NOT ") ++ "eligible for ctail" - | DefRec defs <- dg = "ctailDefGroup: found larger DefRec with names: " ++ unwords [show (defName def) | def <- defs ] + | DefRec [def] <- dg = "ctailDefGroup: " ++ show (defName def) ++ " " ++ (if (hasCTailCall (defTName def) True (defExpr def)) then "IS " else "is NOT ") ++ "eligible for ctail" + | DefRec defs <- dg = "ctailDefGroup: found larger DefRec with names: " ++ unwords [show (defName def) | def <- defs ] | DefNonRec def <- dg = "ctailDefGroup: found DefNonRec with name: " ++ show (defName def) +{- +we generate +- if the runtime can copy contexts (setContextPath) + we always generate a single definition which is optimized a bit if the effect is affine for sure (alwaysAffine) +- otherwise, a single definition of the effect is affine for sure (alwaysAffine) +- or two definitions for multiple resumptions (isMulti) +-} ctailDef :: Bool -> Def -> CTail [DefGroup] ctailDef topLevel def = withCurrentDef def $ diff --git a/src/Core/Specialize.hs b/src/Core/Specialize.hs index 4ce400eb3..2a9ad63c3 100644 --- a/src/Core/Specialize.hs +++ b/src/Core/Specialize.hs @@ -301,14 +301,17 @@ comment = unlines . map ("// " ++) . lines -- The important thing is that we don't try to get the type of the body at the same time as replacing the recursive calls -- since the type of the body depends on the type of the functions that it calls and vice versa replaceCall :: Name -> Expr -> DefSort -> [Bool] -> [Expr] -> Maybe [Type] -> SpecM Expr -replaceCall name expr sort bools args mybeTypeArgs +replaceCall name expr0 sort bools args mybeTypeArgs = do + expr <- uniquefyExprU expr0 + -- extract the specialized parameters let ((newParams, newArgs), (speccedParams, speccedArgs)) = (unzip *** unzip) -- $ (\x@(new, spec) -> trace ("Specializing to newArgs " <> show new) $ x) $ partitionBools bools $ zip (fnParams expr) args + let freev = (tnamesUnions (map freeLocals speccedArgs)) -- create a new (recursive) specialized body where the specialized parameters become local defitions let specBody0 @@ -319,6 +322,7 @@ replaceCall name expr sort bools args mybeTypeArgs $ Let [DefNonRec $ Def param typ arg Private DefVal InlineAuto rangeNull "" -- bind specialized parameters | (TName param typ, arg) <- zip speccedParams speccedArgs] $ fnBody expr + -- substitute self-recursive calls to call our new specialized definition (without the specialized arguments!) specName <- uniqueName "spec" @@ -326,9 +330,10 @@ replaceCall name expr sort bools args mybeTypeArgs specTName = TName specName specType specBody = case specBody0 of Lam args eff (Let specArgs body) - -> uniquefyExpr $ + -> -- uniquefyExpr $ Lam args eff $ - (Let specArgs $ specInnerCalls (TName name (typeOf expr)) specTName bools speccedParams body) + (Let specArgs $ + specInnerCalls (TName name (typeOf expr)) specTName bools speccedParams body) _ -> failure "Specialize.replaceCall: Unexpected output from specialize pass" -- simplify so the new specialized arguments are potentially inlined unlocking potential further specialization diff --git a/src/Core/Uniquefy.hs b/src/Core/Uniquefy.hs index 61cc41a3a..301d20343 100644 --- a/src/Core/Uniquefy.hs +++ b/src/Core/Uniquefy.hs @@ -11,7 +11,7 @@ module Core.Uniquefy ( uniquefy , uniquefyDefGroup {- used for divergence analysis -} - , uniquefyExpr + , uniquefyExpr, uniquefyExprWith, uniquefyExprU , uniquefyDefGroups {- used in inline -} ) where @@ -23,12 +23,13 @@ import qualified Common.NameMap as M import Core.Core import Core.CoreVar( freeLocals ) import Common.Failure +import Common.Unique type Locals = S.NameSet type Renaming = M.NameMap Name data Un a = Un (State -> (a,State)) -data State = St{ locals :: Locals, renaming :: Renaming } +data State = St{ locals :: Locals, renaming :: Renaming, uniq :: Int } instance Functor Un where fmap f (Un u) = Un (\st -> case u st of @@ -42,6 +43,12 @@ instance Monad Un where return x = Un (\st -> (x,st)) (Un u) >>= f = Un (\st0 -> case u st0 of (x,st1) -> case f x of Un u1 -> u1 st1) +instance HasUnique Un where + updateUnique f + = do st' <- updateSt (\st -> st{ uniq = f (uniq st)}) + return (uniq st') + + updateSt f = Un (\st -> (st,f st)) @@ -65,23 +72,40 @@ getRenaming = fmap renaming getSt setLocals l = updateSt (\st -> st{ locals = l }) setRenaming r = updateSt (\st -> st{ renaming = r }) -runUn (Un u) - = fst (u (St S.empty M.empty)) +makeFullUnique + = do st <- getSt + return (uniq st /= 0) + +runUn uniq (Un u) + = fst (u (St S.empty M.empty uniq)) uniquefyExpr :: Expr -> Expr uniquefyExpr expr - = let locals = S.map getName (freeLocals expr) - in runUn $ + = uniquefyExprWith tnamesEmpty expr + +uniquefyExprWith :: TNames -> Expr -> Expr +uniquefyExprWith free expr + = let locals = S.map getName (free `tnamesUnion` (freeLocals expr)) + in runUn 0 $ do setLocals locals uniquefyExprX expr +uniquefyExprU :: HasUnique m => Expr -> m Expr +uniquefyExprU expr + = withUnique $ \uniq0 -> + runUn uniq0 $ + do expr' <- uniquefyExprX expr + uniq1 <- unique + return (expr',uniq1) + + uniquefy :: Core -> Core uniquefy core = core{coreProgDefs = uniquefyDefGroups (coreProgDefs core) } uniquefyDefGroups :: [DefGroup] -> [DefGroup] uniquefyDefGroups dgs - = runUn $ + = runUn 0 $ do locals <- getLocals let toplevelDefs = filter (not . nameIsNil) (map defName (flattenDefGroups dgs)) setLocals (foldr (\name locs -> S.insert (unqualify name) locs) locals toplevelDefs) @@ -99,7 +123,7 @@ uniquefyDefGroups dgs uniquefyDefGroup :: DefGroup -> DefGroup uniquefyDefGroup defgroup - = runUn $ + = runUn 0 $ case defgroup of DefNonRec def -> fmap DefNonRec $ uniquefyDef def @@ -205,10 +229,13 @@ uniquefyName name | nameIsNil name = return name uniquefyName name = do locals <- getLocals - if (S.member name locals) + full <- makeFullUnique + if (full || S.member name locals) then do renaming <- getRenaming - let name1 = findUniqueName 0 name locals - locals1 = S.insert name1 locals + name1 <- if full + then uniqueNameFrom name + else return (findUniqueName 0 name locals) + let locals1 = S.insert name1 locals renaming1 = M.insert name name1 renaming setLocals locals1 setRenaming renaming1 From 37776fdd3d8266d9a0b8edd082ab0f0c0253ec85 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 19 May 2022 21:47:39 -0700 Subject: [PATCH 049/233] update tests --- src/Common/Name.hs | 16 ++++++++++------ test/Spec.hs | 2 ++ test/cgen/specialize/bintree.kk.out | 2 +- test/cgen/specialize/branch.kk.out | 2 +- test/cgen/specialize/fold2.kk.out | 4 ++-- test/cgen/specialize/localdef.kk.out | 2 +- test/cgen/specialize/map3.kk.out | 2 +- test/cgen/specialize/map4.kk.out | 2 +- test/cgen/specialize/map5.kk.out | 2 +- test/cgen/specialize/sieve.kk.out | 2 +- test/cgen/specialize/tree-list.kk.out | 2 +- test/cgen/specialize/twostep-large.kk.out | 2 +- test/cgen/specialize/twostep-large2.kk.out | 20 ++++++++++---------- test/cgen/specialize/zipwithacc.kk.out | 2 +- test/parc/parc11.kk.out | 2 +- test/parc/parc15.kk.out | 10 +++++----- test/parc/parc16.kk.out | 10 +++++----- test/parc/parc17.kk.out | 2 +- test/parc/parc18.kk.out | 12 ++++++------ test/parc/parc20.kk.out | 2 +- test/parc/parc21.kk.out | 4 ++-- test/parc/parc22.kk.out | 4 ++-- test/parc/parc3.kk.out | 14 +++++++------- test/parc/parc4.kk.out | 8 ++++---- 24 files changed, 68 insertions(+), 62 deletions(-) diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 4502b0c8e..ef344cb6a 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -310,7 +310,16 @@ toUniqueName i name reverse (insert (reverse (nameId name))) where insert (c:cs) | c `elem` "'?" = c : insert cs - insert cs = reverse (show i) ++ cs + insert cs = reverse ("." ++ show i) ++ cs + +toHiddenUniqueName :: Int -> String -> Name -> Name +toHiddenUniqueName i "" name + = prepend "." (toUniqueName i name) +toHiddenUniqueName i s name + = makeHiddenName (s ++ show i) xname + where + xname = if (isAlpha (head (nameId name))) then name else newQualified (nameModule name) ("op") + newFieldName i @@ -456,11 +465,6 @@ postpend s cname in newQualified (nameModule name) (nameId name ++ s ++ post) -toHiddenUniqueName :: Int -> String -> Name -> Name -toHiddenUniqueName i s name - = makeHiddenName (s ++ show i) xname - where - xname = if (isAlpha (head (nameId name))) then name else newQualified (nameModule name) ("op") canonicalName :: Int -> Name -> Name canonicalName n name diff --git a/test/Spec.hs b/test/Spec.hs index 95c26d36a..2b9c26704 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -93,7 +93,9 @@ testSanitize kokaDir . sub "\\\\" "/" -- type variable names and box names . sub "\\.box-x[[:digit:]]+(-x[[:digit:]]+)?" ".box" + . sub "(\\.[a-zA-Z])[[:digit:]]+" "\\1" . sub "([a-zA-Z])\\.[[:digit:]]+" "\\1" + . sub "([a-zA-Z])\\.[[:digit:]]+\\.[[:digit:]]+" "\\1" . sub "<[[:digit:]]+>" "<0>" -- for tests using --showhiddentypesigs, -- e.g. .lift250-main => .lift000-main diff --git a/test/cgen/specialize/bintree.kk.out b/test/cgen/specialize/bintree.kk.out index 7197c329a..621410c59 100644 --- a/test/cgen/specialize/bintree.kk.out +++ b/test/cgen/specialize/bintree.kk.out @@ -1,5 +1,5 @@ cgen/specialize/bintree/.lift000-main: (tree : tree) -> tree -cgen/specialize/bintree/.lift000-main: (xs0 : list) -> list +cgen/specialize/bintree/.lift000-main: (xs : list) -> list cgen/specialize/bintree/is-bin: forall (tree : tree) -> bool cgen/specialize/bintree/is-leaf: forall (tree : tree) -> bool cgen/specialize/bintree/main: () -> () diff --git a/test/cgen/specialize/branch.kk.out b/test/cgen/specialize/branch.kk.out index 0986058a1..b892f87db 100644 --- a/test/cgen/specialize/branch.kk.out +++ b/test/cgen/specialize/branch.kk.out @@ -4,6 +4,6 @@ 5 cgen/specialize/branch/.lift000-main: (xs : list) -> console () -cgen/specialize/branch/.lift000-main: forall<_e> (xs0 : list) -> list +cgen/specialize/branch/.lift000-main: forall<_e> (xs : list) -> list cgen/specialize/branch/main: () -> console () cgen/specialize/branch/map_other: forall (xs : list, f : (a) -> b, g : (a) -> b) -> list \ No newline at end of file diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index 15574c01f..6ac541502 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -1,5 +1,5 @@ 55 -cgen/specialize/fold2/.lift135-main: (xs : list, z : int) -> console int -cgen/specialize/fold2/.lift136-main: (xs0 : list, z0 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs : list, z : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs : list, z : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/localdef.kk.out b/test/cgen/specialize/localdef.kk.out index d4b300162..292ec1921 100644 --- a/test/cgen/specialize/localdef.kk.out +++ b/test/cgen/specialize/localdef.kk.out @@ -2,6 +2,6 @@ cgen/specialize/localdef/.lift000-li: forall (f : (int) -> e a, low : int, high : int, acc : list) -> e list cgen/specialize/localdef/.lift000-main: (low : int, high : int, acc : list) -> console list -cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list +cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, high : int, low : int, a) -> e list cgen/specialize/localdef/li: forall (lo : int, hi : int, f : (int) -> e a) -> e list cgen/specialize/localdef/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/map3.kk.out b/test/cgen/specialize/map3.kk.out index 7a2ff2bb1..2fc4302ba 100644 --- a/test/cgen/specialize/map3.kk.out +++ b/test/cgen/specialize/map3.kk.out @@ -1,6 +1,6 @@ [6,7,8,9,10,11,12,13,14,15] -cgen/specialize/map3/.lift000-test: (y : int, xs0 : list) -> list +cgen/specialize/map3/.lift000-test: (y : int, xs : list) -> list cgen/specialize/map3/.lift000-main: (xs : list) -> list cgen/specialize/map3/.mlift000-map-poly: forall (a, list) -> e list cgen/specialize/map3/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list diff --git a/test/cgen/specialize/map4.kk.out b/test/cgen/specialize/map4.kk.out index 08a352ba3..6d13bf07b 100644 --- a/test/cgen/specialize/map4.kk.out +++ b/test/cgen/specialize/map4.kk.out @@ -1,6 +1,6 @@ 160 -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs0 : list) -> list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs : list) -> list cgen/specialize/map4/.lift000-main: (xs : list) -> list cgen/specialize/map4/.mlift000-map-poly: forall (a, list) -> e list cgen/specialize/map4/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list diff --git a/test/cgen/specialize/map5.kk.out b/test/cgen/specialize/map5.kk.out index 0307ea336..e37a3525a 100644 --- a/test/cgen/specialize/map5.kk.out +++ b/test/cgen/specialize/map5.kk.out @@ -1,6 +1,6 @@ 115 -cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs0 : list) -> list +cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs : list) -> list cgen/specialize/map5/.lift000-main: (xs : list) -> list cgen/specialize/map5/main: () -> console () cgen/specialize/map5/test: forall (xs : list, y : int, f : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/sieve.kk.out b/test/cgen/specialize/sieve.kk.out index ae9803b89..eadba163b 100644 --- a/test/cgen/specialize/sieve.kk.out +++ b/test/cgen/specialize/sieve.kk.out @@ -23,7 +23,7 @@ 89 97 -cgen/specialize/sieve/.lift000-sieve: (x : int, xs0 : list) -> div list +cgen/specialize/sieve/.lift000-sieve: (x : int, xs : list) -> div list cgen/specialize/sieve/.lift000-test: (xs : list) -> () cgen/specialize/sieve/.lift000-main: (xs : list) -> () cgen/specialize/sieve/gen-primes: (n : int) -> div list diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index 48cab6312..db572be97 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -8,7 +8,7 @@ cgen/specialize/tree-list/.lift000-main: (xs : list>) -> cgen/specialize/tree-list/.mlift000-op: forall (tree, list>) -> list> cgen/specialize/tree-list/.mlift000-op: forall (f : (a) -> b, xx : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree -cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree +cgen/specialize/tree-list/.mlift000-mapT: forall (children : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> cgen/specialize/tree-list/data: forall (tree : tree) -> a cgen/specialize/tree-list/main: () -> () diff --git a/test/cgen/specialize/twostep-large.kk.out b/test/cgen/specialize/twostep-large.kk.out index a08034a13..af1ad7140 100644 --- a/test/cgen/specialize/twostep-large.kk.out +++ b/test/cgen/specialize/twostep-large.kk.out @@ -2,7 +2,7 @@ 75 cgen/specialize/twostep-large/.lift000-main: (lo : int, hi : int) -> total list -cgen/specialize/twostep-large/.lift000-main: (lo0 : int, hi0 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: (lo : int, hi : int) -> total list cgen/specialize/twostep-large/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large/large: (f : (int) -> total int) -> total int cgen/specialize/twostep-large/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/twostep-large2.kk.out b/test/cgen/specialize/twostep-large2.kk.out index d85ebfeaa..03b9c31c6 100644 --- a/test/cgen/specialize/twostep-large2.kk.out +++ b/test/cgen/specialize/twostep-large2.kk.out @@ -4,23 +4,23 @@ cgen/specialize/twostep-large2/.lift000-repeatN: forall (f : () -> e a, lo : int, hi : int) -> e list cgen/specialize/twostep-large2/.lift000-a: forall (f : () -> e a, lo : int, hi : int) -> e list cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo0 : int, hi0 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo1 : int, hi1 : int) -> total list +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list> +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> console () cgen/specialize/twostep-large2/.lift000-main: () -> total int cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo0 : int, hi0 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo1 : int, hi1 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list cgen/specialize/twostep-large2/.lift000-main: (xs : list) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo2 : int, hi2 : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo3 : int, hi3 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo4 : int, hi4 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs0 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs : list) -> total list cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, lo : int, a) -> e list cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, lo : int, a) -> e list cgen/specialize/twostep-large2/a: forall (i : int, f : () -> e a) -> e list cgen/specialize/twostep-large2/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large2/large: (f : (int) -> total int) -> total int diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index 8fae7751e..6578fdd15 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,6 +1,6 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i : int, acc : list, xs0 : list, ys0 : list) -> console list +cgen/specialize/zipwithacc/.lift000-main: (i : int, acc : list, xs : list, ys : list) -> console list cgen/specialize/zipwithacc/.mlift000-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list cgen/specialize/zipwithacc/main: () -> console () cgen/specialize/zipwithacc/zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list \ No newline at end of file diff --git a/test/parc/parc11.kk.out b/test/parc/parc11.kk.out index 064435bfe..ad05f264c 100644 --- a/test/parc/parc11.kk.out +++ b/test/parc/parc11.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (x : list) -> list = fn(x: list){ match (x) { - (std/core/Cons(((.skip std/core/types/.Box((.pat0: int)) : .Box ) as .box: .Box), (.pat1: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> x; (.skip std/core/Nil() : (list) ) -> std/core/Nil; diff --git a/test/parc/parc15.kk.out b/test/parc/parc15.kk.out index e8dc7f9df..dc5cc9c4a 100644 --- a/test/parc/parc15.kk.out +++ b/test/parc/parc15.kk.out @@ -4,19 +4,19 @@ import std/core = std/core = ""; pub fun test : (xs : list, y : int) -> int = fn(xs: list, y: int){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : int = std/core/types/.dup(x); val _ : () = std/core/types/.drop(y); (match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat2: int)) : .Box ) as .box: .Box), (.pat3: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat3); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -34,7 +34,7 @@ pub fun test : (xs : list, y : int) -> int = std/core/types/.drop(x); 2; }); - (std/core/Cons(((.skip std/core/types/.Box((.pat6: int)) : .Box ) as .box: .Box), (.pat7: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -42,7 +42,7 @@ pub fun test : (xs : list, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat7); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc16.kk.out b/test/parc/parc16.kk.out index 67e38f5a3..a35ca07eb 100644 --- a/test/parc/parc16.kk.out +++ b/test/parc/parc16.kk.out @@ -6,19 +6,19 @@ pub fun test : (xs : list, y : int, z : int) -> int val _ : () = std/core/types/.drop(z); match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : int = std/core/types/.dup(x); val _ : () = std/core/types/.drop(y); (match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat2: int)) : .Box ) as .box: .Box), (.pat3: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat3); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -36,7 +36,7 @@ pub fun test : (xs : list, y : int, z : int) -> int = std/core/types/.drop(x); 2; }); - (std/core/Cons(((.skip std/core/types/.Box((.pat6: int)) : .Box ) as .box: .Box), (.pat7: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -44,7 +44,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat7); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc17.kk.out b/test/parc/parc17.kk.out index d371bab6f..1d18634ae 100644 --- a/test/parc/parc17.kk.out +++ b/test/parc/parc17.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (xs : list) -> list = fn(xs: list){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> xs; (.skip std/core/Nil() : (list) ) -> std/core/Nil; diff --git a/test/parc/parc18.kk.out b/test/parc/parc18.kk.out index 8b4d98ebe..1c35bdf91 100644 --- a/test/parc/parc18.kk.out +++ b/test/parc/parc18.kk.out @@ -4,21 +4,21 @@ import std/core = std/core = ""; pub fun test : forall (xs : list, ys : list) -> list = fn(xs: list<0>, ys: list<0>){ match (xs) { - (std/core/Cons((z: 43), (.pat0: list<0>)) : list ) + (std/core/Cons((z: 43), (.pat: list<0>)) : list ) -> (match (ys) { - (std/core/Cons((z0: 43), (.pat2: list<0>)) : list ) + (std/core/Cons((z: 43), (.pat: list<0>)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(ys))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat2); + = std/core/types/.drop(.pat); std/core/types/(); std/core/types/.free(ys); _ -> val _ : () = val _ : a - = std/core/types/.dup(z0); + = std/core/types/.dup(z); std/core/types/(); val _ : () = std/core/types/.dec-ref(ys); @@ -33,7 +33,7 @@ pub fun test : forall (xs : list, ys : list) -> list = val _ : () = std/core/types/.drop(z); val _ : () - = std/core/types/.drop(.pat0); + = std/core/types/.drop(.pat); std/core/types/(); std/core/types/.assign-reuse(.ru, (std/core/types/.reuse(xs))); _ @@ -43,7 +43,7 @@ pub fun test : forall (xs : list, ys : list) -> list = std/core/types/.dec-ref(xs); std/core/types/(); }); - std/core/types/.alloc-at(.ru, (std/core/Cons(z0, std/core/Nil))); + std/core/types/.alloc-at(.ru, (std/core/Cons(z, std/core/Nil))); (.skip std/core/Nil() : (list) ) -> xs; }); diff --git a/test/parc/parc20.kk.out b/test/parc/parc20.kk.out index 2735ef360..a55edd9ad 100644 --- a/test/parc/parc20.kk.out +++ b/test/parc/parc20.kk.out @@ -5,7 +5,7 @@ import std/core = std/core = ""; pub fun test : (xs : list) -> list = fn(xs: list){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) -> val _ : int = std/core/types/.dup(x); std/core/Cons((std/core/types/.box(x)), xs); diff --git a/test/parc/parc21.kk.out b/test/parc/parc21.kk.out index 99b044237..c957d168b 100644 --- a/test/parc/parc21.kk.out +++ b/test/parc/parc21.kk.out @@ -17,9 +17,9 @@ pub fun test : () -> console int = parc/parc21/bo(3, 4); val _ : () = std/core/prints((std/core/show(i))); - val _0 : () + val _.0 : () = std/core/prints((std/core/show(3))); - val _1 : () + val _.1 : () = std/core/prints((std/core/show(4))); parc/parc21/bo(3, 4); }; \ No newline at end of file diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index a234ddd93..e569fd41f 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -13,8 +13,8 @@ pub fun i : (^ hello : parc/parc22/hello) -> int }; }; pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/hello - = fn(.this: parc/parc22/hello, i0: optional){ - parc/parc22/World((match (i0) { + = fn(.this: parc/parc22/hello, i: optional){ + parc/parc22/World((match (i) { (std/core/types/Optional(((.skip std/core/types/.Box((.i: int)) : .Box ) as .box: .Box)) : optional ) -> val _ : () = std/core/types/.drop(.this, (std/core/int32(1))); diff --git a/test/parc/parc3.kk.out b/test/parc/parc3.kk.out index 36c30008a..ff0338641 100644 --- a/test/parc/parc3.kk.out +++ b/test/parc/parc3.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (xs : list, y : int, z : int) -> int = fn(xs: list, y: int, z: int){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) | std/core/(==.1)(x, z) -> val _ : () = std/core/types/.drop(z); val _ : () @@ -14,7 +14,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat0); + = std/core/types/.drop(.pat); std/core/types/(); std/core/types/.free(xs); _ @@ -27,15 +27,15 @@ pub fun test : (xs : list, y : int, z : int) -> int std/core/types/(); }); x; - (std/core/Cons(((.skip std/core/types/.Box((x0: int)) : .Box ) as .box: .Box), (.pat2: list)) : list ) - | std/core/(==.1)(x0, y) -> val _ : () + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + | std/core/(==.1)(x, y) -> val _ : () = std/core/types/.drop(z); val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat2); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -48,7 +48,7 @@ pub fun test : (xs : list, y : int, z : int) -> int std/core/types/(); }); y; - (std/core/Cons(((.skip std/core/types/.Box((.pat4: int)) : .Box ) as .box: .Box), (.pat5: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) | std/core/(==.1)(y, z) -> val _ : () = std/core/types/.drop(z); val _ : () @@ -58,7 +58,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat5); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc4.kk.out b/test/parc/parc4.kk.out index da0b0fd56..dfe60e3e5 100644 --- a/test/parc/parc4.kk.out +++ b/test/parc/parc4.kk.out @@ -5,7 +5,7 @@ pub fun test : (xs : list>, y : int) -> int = fn(xs: list>, y: int){ match (xs) { (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Just(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box)) : maybe ) as - .pat0: maybe)) : .Box ) as .box: .Box), (.pat1: list>)) : list> ) + .pat: maybe)) : .Box ) as .box: .Box), (.pat: list>)) : list> ) | std/core/(==.1)(x, y) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -13,7 +13,7 @@ pub fun test : (xs : list>, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat1); + = std/core/types/.drop(.pat); val _ : int = std/core/types/.dup(x); val _ : () @@ -30,7 +30,7 @@ pub fun test : (xs : list>, y : int) -> int std/core/types/(); }); x; - (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Nothing() : maybe ) as .pat3: maybe)) : .Box ) as .box: .Box), (.pat4: list< + (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Nothing() : maybe ) as .pat: maybe)) : .Box ) as .box: .Box), (.pat: list< maybe>)) : list> ) -> val _ : () = std/core/types/.drop(y); @@ -39,7 +39,7 @@ pub fun test : (xs : list>, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat4); + = std/core/types/.drop(.pat); val _ : () = std/core/types/.drop(.box); std/core/types/(); From e09293f2cb6c4f872a4a90c10bc44e8283799aa3 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Sat, 21 May 2022 14:25:45 +0200 Subject: [PATCH 050/233] Add TRMC-FBIP to binarytrees benchmark --- test/bench/koka/binarytrees.kk | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/test/bench/koka/binarytrees.kk b/test/bench/koka/binarytrees.kk index a710a2dcd..f817ad9dc 100644 --- a/test/bench/koka/binarytrees.kk +++ b/test/bench/koka/binarytrees.kk @@ -53,8 +53,41 @@ fun make-rec( depth : int ) : div tree then Node( make-rec(depth - 1), make-rec(depth - 1) ) else Node( Tip, Tip ) +type build + Root + GoRight( depth : int, up : build ) + +fun make-trmc-up( t : tree, b : build ) : div tree + match b + GoRight(depth, Root) -> + Node(t, make-trmc( depth, Root )) + GoRight(depth, up) -> + make-trmc-up( Node(t, make-trmc( depth, Root )), up ) + Root -> t + +fun make-trmc( depth : int, b : build ) : div tree + if depth > 0 + then make-trmc( depth - 1, GoRight(depth - 1, b)) + else make-trmc-up( Node(Tip,Tip), b) + +fun make-trmc-fbip( dir : direction, b : build ) : div tree + match dir + Down(depth) -> + if depth > 0 + then make-trmc-fbip( Down(depth - 1), GoRight(depth - 1, b)) + else make-trmc-fbip( Up(Node(Tip,Tip)), b) + Up(t) -> + match b + GoRight(depth, Root) -> + Node(t, make-trmc-fbip( Down(depth), Root )) + GoRight(depth, up) -> + make-trmc-fbip(Up(Node(t, make-trmc-fbip( Down(depth), Root ))), up ) + Root -> t + fun make( depth : int ) : div tree make-rec(depth) + // make-trmc( depth, Root ) + // make-trmc-fbip( Down( depth), Root ) // make-fbip(Down(depth), Top) // make-down( depth, Top ) From 2433611a20142f554dcb2d72f169b960755d1849 Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 21 May 2022 07:30:57 -0700 Subject: [PATCH 051/233] fix kind application bug in the resume-context type --- src/Common/Name.hs | 2 +- src/Core/Specialize.hs | 3 +-- src/Type/Kind.hs | 7 ++++--- src/Type/Type.hs | 2 +- test/algeff/perf1c.kk | 41 ++++++++++++++++------------------------- test/algeff/perf2.kk | 2 ++ 6 files changed, 25 insertions(+), 32 deletions(-) diff --git a/src/Common/Name.hs b/src/Common/Name.hs index ef344cb6a..87f729f14 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -310,7 +310,7 @@ toUniqueName i name reverse (insert (reverse (nameId name))) where insert (c:cs) | c `elem` "'?" = c : insert cs - insert cs = reverse ("." ++ show i) ++ cs + insert cs = reverse (show i) ++ cs toHiddenUniqueName :: Int -> String -> Name -> Name toHiddenUniqueName i "" name diff --git a/src/Core/Specialize.hs b/src/Core/Specialize.hs index 2a9ad63c3..176fd655b 100644 --- a/src/Core/Specialize.hs +++ b/src/Core/Specialize.hs @@ -311,8 +311,7 @@ replaceCall name expr0 sort bools args mybeTypeArgs -- $ (\x@(new, spec) -> trace ("Specializing to newArgs " <> show new) $ x) $ partitionBools bools $ zip (fnParams expr) args - let freev = (tnamesUnions (map freeLocals speccedArgs)) - + -- create a new (recursive) specialized body where the specialized parameters become local defitions let specBody0 = (\body -> case mybeTypeArgs of diff --git a/src/Type/Kind.hs b/src/Type/Kind.hs index 94db9fe39..40b29de13 100644 --- a/src/Type/Kind.hs +++ b/src/Type/Kind.hs @@ -135,8 +135,8 @@ instance HasKind Type where TCon c -> getKind c TSyn syn xs tp -> -- getKind tp {- this is wrong for partially applied type synonym arguments, see "kind/alias3" test -} -- if (null xs) then getKind tp else - kindApply xs (getKind syn) - TApp tp args -> kindApply args (getKind tp) + kindApply xs (getKind syn) + TApp tp args -> kindApply args (getKind tp) {- case collect [] (getKind tp) of (kres:_) -> kres _ -> failure ("Type.Kind: illegal kind in type application? " ++ show (getKind tp) ) @@ -148,4 +148,5 @@ instance HasKind Type where kindApply [] k = k kindApply (_:rest) (KApp (KApp arr k1) k2) = kindApply rest k2 - kindApply _ k = failure ("Type.Kind.kindApply: illegal kind in application? " ++ show k) + kindApply args k = failure ("Type.Kind.kindApply: illegal kind in application? " ++ show (k) ++ " to " ++ show args + ++ "\n " ++ show tau) diff --git a/src/Type/Type.hs b/src/Type/Type.hs index ab3d6bb5d..fd24e478a 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -514,7 +514,7 @@ typeResumeContext :: Tau -> Effect -> Effect -> Tau -> Tau typeResumeContext b e e0 r = TApp (TCon tcon) [b,e,e0,r] where - tcon = TypeCon nameTpResumeContext (kindFun kindStar (kindFun kindEffect (kindFun kindEffect kindStar))) + tcon = TypeCon nameTpResumeContext (kindFun kindStar (kindFun kindEffect (kindFun kindEffect (kindFun kindStar kindStar)))) typeRef :: Tau typeRef diff --git a/test/algeff/perf1c.kk b/test/algeff/perf1c.kk index 9810428b9..ea5a0ae0c 100644 --- a/test/algeff/perf1c.kk +++ b/test/algeff/perf1c.kk @@ -1,43 +1,34 @@ import std/time/timer -effect state { +effect state fun get() : s fun put(i : s) : () -} -fun fib(n) { - if (n<=1) then 1 else fib(n - 1) + fib(n - 2); -} +fun fib(n) + if (n<=1) then 1 else fib(n - 1) + fib(n - 2) -fun comp() { +fun comp() fib(4) -} -fun count() { - comp(); +fun count() + comp() val i = get() - if (i == 0) then i else { + if (i == 0) then i else put(i - 1) count() - } -} - -fun test-normal(i0,action) { +fun test-normal(i0,action) var i := i0 - handle({mask(action)}) { - fun get() { i } - fun put(j) { i := j; () } - } -} + with handler + fun get() i + fun put(j) i := j + action() -fun test-direct(i) { - comp(); +fun test-direct(i) + comp() if (i==0) then i else test-direct(i - 1) -} -val n = 1000000 -fun main() { +val n = 10000000 +fun main() print-elapsed({test-direct(n)}, "direct") print-elapsed({test-normal(n,count)},"handler") -} diff --git a/test/algeff/perf2.kk b/test/algeff/perf2.kk index abc4b7187..6dd53230b 100644 --- a/test/algeff/perf2.kk +++ b/test/algeff/perf2.kk @@ -81,6 +81,8 @@ fun queens-choose(n : int ) : div solutions { fun test(n) { print-elapsed({ queens(n) }, "regular").length.println print-elapsed({ queens-choose(n) }, "algebraic").length.println + //queens(n).length.println + //queens-choose(n).length.println } fun main() { From 61029844dbdebbc7abd64ac6c617d8132fd56693 Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 21 May 2022 07:40:42 -0700 Subject: [PATCH 052/233] fix test suite for -O2 --- test/Spec.hs | 4 +-- test/cgen/specialize/bintree.kk.out | 4 +-- test/cgen/specialize/branch.kk.out | 4 +-- test/cgen/specialize/fold1.kk.out | 4 +-- test/cgen/specialize/fold2.kk.out | 4 +-- test/cgen/specialize/localdef.kk.out | 2 +- test/cgen/specialize/map-alias.kk.out | 2 +- test/cgen/specialize/map.kk.out | 4 +-- test/cgen/specialize/map2.kk.out | 4 +-- test/cgen/specialize/map3.kk.out | 4 +-- test/cgen/specialize/map4.kk.out | 4 +-- test/cgen/specialize/map5.kk.out | 4 +-- test/cgen/specialize/maptwice.kk.out | 4 +-- test/cgen/specialize/sieve.kk.out | 6 ++--- test/cgen/specialize/tree-list.kk.out | 10 ++++---- test/cgen/specialize/twostep-large.kk.out | 4 +-- test/cgen/specialize/twostep-large2.kk.out | 30 +++++++++++----------- test/cgen/specialize/zipwithacc.kk.out | 2 +- test/parc/parc11.kk.out | 2 +- test/parc/parc15.kk.out | 10 ++++---- test/parc/parc16.kk.out | 10 ++++---- test/parc/parc17.kk.out | 2 +- test/parc/parc18.kk.out | 12 ++++----- test/parc/parc20.kk.out | 2 +- test/parc/parc21.kk.out | 4 +-- test/parc/parc22.kk.out | 4 +-- test/parc/parc3.kk.out | 14 +++++----- test/parc/parc4.kk.out | 8 +++--- 28 files changed, 84 insertions(+), 84 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 2b9c26704..29dcd7a01 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -95,7 +95,7 @@ testSanitize kokaDir . sub "\\.box-x[[:digit:]]+(-x[[:digit:]]+)?" ".box" . sub "(\\.[a-zA-Z])[[:digit:]]+" "\\1" . sub "([a-zA-Z])\\.[[:digit:]]+" "\\1" - . sub "([a-zA-Z])\\.[[:digit:]]+\\.[[:digit:]]+" "\\1" + -- . sub "([a-zA-Z])\\.[[:digit:]]+\\.[[:digit:]]+" "\\1" . sub "<[[:digit:]]+>" "<0>" -- for tests using --showhiddentypesigs, -- e.g. .lift250-main => .lift000-main @@ -119,7 +119,7 @@ runKoka cfg kokaDir fp = do caseFlags <- readFlagsFile (fp ++ ".flags") let relTest = makeRelative kokaDir fp optFlag = if (opt (options cfg) /= 0) then ["-O" ++ show (opt (options cfg))] else [] - kokaFlags = flags cfg ++ optFlag ++ caseFlags + kokaFlags = optFlag ++ flags cfg ++ caseFlags if (cabal (options cfg)) then do let argv = ["new-run", "koka", "--"] ++ kokaFlags ++ [relTest] testSanitize kokaDir <$> readProcess "cabal" argv "" diff --git a/test/cgen/specialize/bintree.kk.out b/test/cgen/specialize/bintree.kk.out index 621410c59..315dc0a39 100644 --- a/test/cgen/specialize/bintree.kk.out +++ b/test/cgen/specialize/bintree.kk.out @@ -1,5 +1,5 @@ -cgen/specialize/bintree/.lift000-main: (tree : tree) -> tree -cgen/specialize/bintree/.lift000-main: (xs : list) -> list +cgen/specialize/bintree/.lift000-main: (tree350 : tree) -> tree +cgen/specialize/bintree/.lift000-main: (xs358 : list) -> list cgen/specialize/bintree/is-bin: forall (tree : tree) -> bool cgen/specialize/bintree/is-leaf: forall (tree : tree) -> bool cgen/specialize/bintree/main: () -> () diff --git a/test/cgen/specialize/branch.kk.out b/test/cgen/specialize/branch.kk.out index b892f87db..06efa08df 100644 --- a/test/cgen/specialize/branch.kk.out +++ b/test/cgen/specialize/branch.kk.out @@ -3,7 +3,7 @@ 2 5 -cgen/specialize/branch/.lift000-main: (xs : list) -> console () -cgen/specialize/branch/.lift000-main: forall<_e> (xs : list) -> list +cgen/specialize/branch/.lift000-main: (xs416 : list) -> console () +cgen/specialize/branch/.lift000-main: forall<_e> (xs423 : list) -> list cgen/specialize/branch/main: () -> console () cgen/specialize/branch/map_other: forall (xs : list, f : (a) -> b, g : (a) -> b) -> list \ No newline at end of file diff --git a/test/cgen/specialize/fold1.kk.out b/test/cgen/specialize/fold1.kk.out index 64d036541..2ae94b10f 100644 --- a/test/cgen/specialize/fold1.kk.out +++ b/test/cgen/specialize/fold1.kk.out @@ -4,8 +4,8 @@ add default effect for std/core/exn cgen/specialize/fold1/.hmain: () -> console () -cgen/specialize/fold1/.lift000-main: (xs : list, z : int) -> int -cgen/specialize/fold1/.mlift000-op: (xx : list, int) -> int +cgen/specialize/fold1/.lift000-main: (xs655 : list, z656 : int) -> int +cgen/specialize/fold1/.mlift000-op: (xx660 : list, int) -> int cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index 6ac541502..05f2341cd 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -1,5 +1,5 @@ 55 -cgen/specialize/fold2/.lift000-main: (xs : list, z : int) -> console int -cgen/specialize/fold2/.lift000-main: (xs : list, z : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs231 : list, z232 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs237 : list, z238 : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/localdef.kk.out b/test/cgen/specialize/localdef.kk.out index 292ec1921..d4b300162 100644 --- a/test/cgen/specialize/localdef.kk.out +++ b/test/cgen/specialize/localdef.kk.out @@ -2,6 +2,6 @@ cgen/specialize/localdef/.lift000-li: forall (f : (int) -> e a, low : int, high : int, acc : list) -> e list cgen/specialize/localdef/.lift000-main: (low : int, high : int, acc : list) -> console list -cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, high : int, low : int, a) -> e list +cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list cgen/specialize/localdef/li: forall (lo : int, hi : int, f : (int) -> e a) -> e list cgen/specialize/localdef/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/map-alias.kk.out b/test/cgen/specialize/map-alias.kk.out index 9e858963b..9a4e3c1f8 100644 --- a/test/cgen/specialize/map-alias.kk.out +++ b/test/cgen/specialize/map-alias.kk.out @@ -1,6 +1,6 @@ [2,3,4] -cgen/specialize/map-alias/.lift000-main: (xs : list) -> console list +cgen/specialize/map-alias/.lift000-main: (xs411 : list) -> console list cgen/specialize/map-alias/main: () -> console () cgen/specialize/map-alias/map2: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map-alias/map3: forall (xs : list, f : (a) -> e b) -> e list \ No newline at end of file diff --git a/test/cgen/specialize/map.kk.out b/test/cgen/specialize/map.kk.out index e209a49f1..8cbc9a659 100644 --- a/test/cgen/specialize/map.kk.out +++ b/test/cgen/specialize/map.kk.out @@ -1,7 +1,7 @@ [2,3,4] -cgen/specialize/map/.lift000-test: (xs : list) -> list -cgen/specialize/map/.lift000-main: (xs : list) -> list +cgen/specialize/map/.lift000-test: (xs223 : list) -> list +cgen/specialize/map/.lift000-main: (xs231 : list) -> list cgen/specialize/map/main: () -> console () cgen/specialize/map/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/test: () -> list \ No newline at end of file diff --git a/test/cgen/specialize/map2.kk.out b/test/cgen/specialize/map2.kk.out index 145e83417..0cf89a488 100644 --- a/test/cgen/specialize/map2.kk.out +++ b/test/cgen/specialize/map2.kk.out @@ -1,7 +1,7 @@ [3,4,5] -cgen/specialize/map2/.lift000-test: (y : int, xs : list) -> list -cgen/specialize/map2/.lift000-main: (xs : list) -> list +cgen/specialize/map2/.lift000-test: (y : int, xs231 : list) -> list +cgen/specialize/map2/.lift000-main: (xs239 : list) -> list cgen/specialize/map2/main: () -> console () cgen/specialize/map2/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/test: (y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map3.kk.out b/test/cgen/specialize/map3.kk.out index 2fc4302ba..b05943fe6 100644 --- a/test/cgen/specialize/map3.kk.out +++ b/test/cgen/specialize/map3.kk.out @@ -1,7 +1,7 @@ [6,7,8,9,10,11,12,13,14,15] -cgen/specialize/map3/.lift000-test: (y : int, xs : list) -> list -cgen/specialize/map3/.lift000-main: (xs : list) -> list +cgen/specialize/map3/.lift000-test: (y : int, xs386 : list) -> list +cgen/specialize/map3/.lift000-main: (xs394 : list) -> list cgen/specialize/map3/.mlift000-map-poly: forall (a, list) -> e list cgen/specialize/map3/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list cgen/specialize/map3/main: () -> console () diff --git a/test/cgen/specialize/map4.kk.out b/test/cgen/specialize/map4.kk.out index 6d13bf07b..c64d5c2da 100644 --- a/test/cgen/specialize/map4.kk.out +++ b/test/cgen/specialize/map4.kk.out @@ -1,7 +1,7 @@ 160 -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs : list) -> list -cgen/specialize/map4/.lift000-main: (xs : list) -> list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs321 : list) -> list +cgen/specialize/map4/.lift000-main: (xs329 : list) -> list cgen/specialize/map4/.mlift000-map-poly: forall (a, list) -> e list cgen/specialize/map4/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list cgen/specialize/map4/main: () -> console () diff --git a/test/cgen/specialize/map5.kk.out b/test/cgen/specialize/map5.kk.out index e37a3525a..f3162565a 100644 --- a/test/cgen/specialize/map5.kk.out +++ b/test/cgen/specialize/map5.kk.out @@ -1,6 +1,6 @@ 115 -cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs : list) -> list -cgen/specialize/map5/.lift000-main: (xs : list) -> list +cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs359 : list) -> list +cgen/specialize/map5/.lift000-main: (xs367 : list) -> list cgen/specialize/map5/main: () -> console () cgen/specialize/map5/test: forall (xs : list, y : int, f : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/maptwice.kk.out b/test/cgen/specialize/maptwice.kk.out index aec55f4f0..3741fad75 100644 --- a/test/cgen/specialize/maptwice.kk.out +++ b/test/cgen/specialize/maptwice.kk.out @@ -2,8 +2,8 @@ add default effect for std/core/exn cgen/specialize/maptwice/.hmain: () -> console () -cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs : list>) -> total list> -cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs618 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs626 : list>) -> total list> cgen/specialize/maptwice/.mlift000-main: (int) -> exn () cgen/specialize/maptwice/.mlift000-main: (list) -> exn () cgen/specialize/maptwice/main: () -> () diff --git a/test/cgen/specialize/sieve.kk.out b/test/cgen/specialize/sieve.kk.out index eadba163b..37784e300 100644 --- a/test/cgen/specialize/sieve.kk.out +++ b/test/cgen/specialize/sieve.kk.out @@ -23,9 +23,9 @@ 89 97 -cgen/specialize/sieve/.lift000-sieve: (x : int, xs : list) -> div list -cgen/specialize/sieve/.lift000-test: (xs : list) -> () -cgen/specialize/sieve/.lift000-main: (xs : list) -> () +cgen/specialize/sieve/.lift000-sieve: (x : int, xs341 : list) -> div list +cgen/specialize/sieve/.lift000-test: (xs351 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs358 : list) -> () cgen/specialize/sieve/gen-primes: (n : int) -> div list cgen/specialize/sieve/main: () -> () cgen/specialize/sieve/sieve: (xs : list, max : int) -> div list diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index db572be97..7d83c252a 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -1,14 +1,14 @@ Tree(2, [Tree(3, []), Tree(4, [])]) cgen/specialize/tree-list/.copy: forall (tree, data : optional, children : optional>>) -> tree -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs : list>) -> list> -cgen/specialize/tree-list/.lift000-show: (xs : list>) -> div list +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1149 : list>) -> list> +cgen/specialize/tree-list/.lift000-show: (xs1157 : list>) -> div list cgen/specialize/tree-list/.lift000-main: (tree) -> tree -cgen/specialize/tree-list/.lift000-main: (xs : list>) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1171 : list>) -> list> cgen/specialize/tree-list/.mlift000-op: forall (tree, list>) -> list> -cgen/specialize/tree-list/.mlift000-op: forall (f : (a) -> b, xx : list>, tree) -> list> +cgen/specialize/tree-list/.mlift000-op: forall (f : (a) -> b, xx1153 : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree -cgen/specialize/tree-list/.mlift000-mapT: forall (children : list>, f : (a) -> b, b) -> tree +cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> cgen/specialize/tree-list/data: forall (tree : tree) -> a cgen/specialize/tree-list/main: () -> () diff --git a/test/cgen/specialize/twostep-large.kk.out b/test/cgen/specialize/twostep-large.kk.out index af1ad7140..eab61791e 100644 --- a/test/cgen/specialize/twostep-large.kk.out +++ b/test/cgen/specialize/twostep-large.kk.out @@ -1,8 +1,8 @@ 75 75 -cgen/specialize/twostep-large/.lift000-main: (lo : int, hi : int) -> total list -cgen/specialize/twostep-large/.lift000-main: (lo : int, hi : int) -> total list +cgen/specialize/twostep-large/.lift000-main: (lo257 : int, hi258 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: (lo265 : int, hi266 : int) -> total list cgen/specialize/twostep-large/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large/large: (f : (int) -> total int) -> total int cgen/specialize/twostep-large/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/twostep-large2.kk.out b/test/cgen/specialize/twostep-large2.kk.out index 03b9c31c6..cca6a5956 100644 --- a/test/cgen/specialize/twostep-large2.kk.out +++ b/test/cgen/specialize/twostep-large2.kk.out @@ -1,26 +1,26 @@ 65000 65000 -cgen/specialize/twostep-large2/.lift000-repeatN: forall (f : () -> e a, lo : int, hi : int) -> e list -cgen/specialize/twostep-large2/.lift000-a: forall (f : () -> e a, lo : int, hi : int) -> e list -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list +cgen/specialize/twostep-large2/.lift000-repeatN: forall (f : () -> e a, lo477 : int, hi478 : int) -> e list +cgen/specialize/twostep-large2/.lift000-a: forall (f : () -> e a, lo485 : int, hi486 : int) -> e list +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo493 : int, hi494 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo501 : int, hi502 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo509 : int, hi510 : int) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> console () cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo531 : int, hi532 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo539 : int, hi540 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo547 : int, hi548 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs555 : list) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo571 : int, hi572 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo579 : int, hi580 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo587 : int, hi588 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs595 : list) -> total list cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, lo : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, lo : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list cgen/specialize/twostep-large2/a: forall (i : int, f : () -> e a) -> e list cgen/specialize/twostep-large2/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large2/large: (f : (int) -> total int) -> total int diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index 6578fdd15..cbc519c04 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,6 +1,6 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i : int, acc : list, xs : list, ys : list) -> console list +cgen/specialize/zipwithacc/.lift000-main: (i368 : int, acc369 : list, xs370 : list, ys371 : list) -> console list cgen/specialize/zipwithacc/.mlift000-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list cgen/specialize/zipwithacc/main: () -> console () cgen/specialize/zipwithacc/zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list \ No newline at end of file diff --git a/test/parc/parc11.kk.out b/test/parc/parc11.kk.out index ad05f264c..064435bfe 100644 --- a/test/parc/parc11.kk.out +++ b/test/parc/parc11.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (x : list) -> list = fn(x: list){ match (x) { - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat0: int)) : .Box ) as .box: .Box), (.pat1: list)) : list ) -> x; (.skip std/core/Nil() : (list) ) -> std/core/Nil; diff --git a/test/parc/parc15.kk.out b/test/parc/parc15.kk.out index dc5cc9c4a..e8dc7f9df 100644 --- a/test/parc/parc15.kk.out +++ b/test/parc/parc15.kk.out @@ -4,19 +4,19 @@ import std/core = std/core = ""; pub fun test : (xs : list, y : int) -> int = fn(xs: list, y: int){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) -> val _ : int = std/core/types/.dup(x); val _ : () = std/core/types/.drop(y); (match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat2: int)) : .Box ) as .box: .Box), (.pat3: list)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat3); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -34,7 +34,7 @@ pub fun test : (xs : list, y : int) -> int = std/core/types/.drop(x); 2; }); - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat6: int)) : .Box ) as .box: .Box), (.pat7: list)) : list ) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -42,7 +42,7 @@ pub fun test : (xs : list, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat7); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc16.kk.out b/test/parc/parc16.kk.out index a35ca07eb..67e38f5a3 100644 --- a/test/parc/parc16.kk.out +++ b/test/parc/parc16.kk.out @@ -6,19 +6,19 @@ pub fun test : (xs : list, y : int, z : int) -> int val _ : () = std/core/types/.drop(z); match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) -> val _ : int = std/core/types/.dup(x); val _ : () = std/core/types/.drop(y); (match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat2: int)) : .Box ) as .box: .Box), (.pat3: list)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat3); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -36,7 +36,7 @@ pub fun test : (xs : list, y : int, z : int) -> int = std/core/types/.drop(x); 2; }); - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat6: int)) : .Box ) as .box: .Box), (.pat7: list)) : list ) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -44,7 +44,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat7); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc17.kk.out b/test/parc/parc17.kk.out index 1d18634ae..d371bab6f 100644 --- a/test/parc/parc17.kk.out +++ b/test/parc/parc17.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (xs : list) -> list = fn(xs: list){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) -> xs; (.skip std/core/Nil() : (list) ) -> std/core/Nil; diff --git a/test/parc/parc18.kk.out b/test/parc/parc18.kk.out index 1c35bdf91..8b4d98ebe 100644 --- a/test/parc/parc18.kk.out +++ b/test/parc/parc18.kk.out @@ -4,21 +4,21 @@ import std/core = std/core = ""; pub fun test : forall (xs : list, ys : list) -> list = fn(xs: list<0>, ys: list<0>){ match (xs) { - (std/core/Cons((z: 43), (.pat: list<0>)) : list ) + (std/core/Cons((z: 43), (.pat0: list<0>)) : list ) -> (match (ys) { - (std/core/Cons((z: 43), (.pat: list<0>)) : list ) + (std/core/Cons((z0: 43), (.pat2: list<0>)) : list ) -> val _ : () = (match ((std/core/types/.is-unique(ys))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat2); std/core/types/(); std/core/types/.free(ys); _ -> val _ : () = val _ : a - = std/core/types/.dup(z); + = std/core/types/.dup(z0); std/core/types/(); val _ : () = std/core/types/.dec-ref(ys); @@ -33,7 +33,7 @@ pub fun test : forall (xs : list, ys : list) -> list = val _ : () = std/core/types/.drop(z); val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat0); std/core/types/(); std/core/types/.assign-reuse(.ru, (std/core/types/.reuse(xs))); _ @@ -43,7 +43,7 @@ pub fun test : forall (xs : list, ys : list) -> list = std/core/types/.dec-ref(xs); std/core/types/(); }); - std/core/types/.alloc-at(.ru, (std/core/Cons(z, std/core/Nil))); + std/core/types/.alloc-at(.ru, (std/core/Cons(z0, std/core/Nil))); (.skip std/core/Nil() : (list) ) -> xs; }); diff --git a/test/parc/parc20.kk.out b/test/parc/parc20.kk.out index a55edd9ad..2735ef360 100644 --- a/test/parc/parc20.kk.out +++ b/test/parc/parc20.kk.out @@ -5,7 +5,7 @@ import std/core = std/core = ""; pub fun test : (xs : list) -> list = fn(xs: list){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) -> val _ : int = std/core/types/.dup(x); std/core/Cons((std/core/types/.box(x)), xs); diff --git a/test/parc/parc21.kk.out b/test/parc/parc21.kk.out index c957d168b..99b044237 100644 --- a/test/parc/parc21.kk.out +++ b/test/parc/parc21.kk.out @@ -17,9 +17,9 @@ pub fun test : () -> console int = parc/parc21/bo(3, 4); val _ : () = std/core/prints((std/core/show(i))); - val _.0 : () + val _0 : () = std/core/prints((std/core/show(3))); - val _.1 : () + val _1 : () = std/core/prints((std/core/show(4))); parc/parc21/bo(3, 4); }; \ No newline at end of file diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index e569fd41f..a234ddd93 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -13,8 +13,8 @@ pub fun i : (^ hello : parc/parc22/hello) -> int }; }; pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/hello - = fn(.this: parc/parc22/hello, i: optional){ - parc/parc22/World((match (i) { + = fn(.this: parc/parc22/hello, i0: optional){ + parc/parc22/World((match (i0) { (std/core/types/Optional(((.skip std/core/types/.Box((.i: int)) : .Box ) as .box: .Box)) : optional ) -> val _ : () = std/core/types/.drop(.this, (std/core/int32(1))); diff --git a/test/parc/parc3.kk.out b/test/parc/parc3.kk.out index ff0338641..36c30008a 100644 --- a/test/parc/parc3.kk.out +++ b/test/parc/parc3.kk.out @@ -4,7 +4,7 @@ import std/core = std/core = ""; pub fun test : (xs : list, y : int, z : int) -> int = fn(xs: list, y: int, z: int){ match (xs) { - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat0: list)) : list ) | std/core/(==.1)(x, z) -> val _ : () = std/core/types/.drop(z); val _ : () @@ -14,7 +14,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat0); std/core/types/(); std/core/types/.free(xs); _ @@ -27,15 +27,15 @@ pub fun test : (xs : list, y : int, z : int) -> int std/core/types/(); }); x; - (std/core/Cons(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) - | std/core/(==.1)(x, y) -> val _ : () + (std/core/Cons(((.skip std/core/types/.Box((x0: int)) : .Box ) as .box: .Box), (.pat2: list)) : list ) + | std/core/(==.1)(x0, y) -> val _ : () = std/core/types/.drop(z); val _ : () = (match ((std/core/types/.is-unique(xs))) { (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat2); val _ : () = std/core/types/.drop(.box); std/core/types/(); @@ -48,7 +48,7 @@ pub fun test : (xs : list, y : int, z : int) -> int std/core/types/(); }); y; - (std/core/Cons(((.skip std/core/types/.Box((.pat: int)) : .Box ) as .box: .Box), (.pat: list)) : list ) + (std/core/Cons(((.skip std/core/types/.Box((.pat4: int)) : .Box ) as .box: .Box), (.pat5: list)) : list ) | std/core/(==.1)(y, z) -> val _ : () = std/core/types/.drop(z); val _ : () @@ -58,7 +58,7 @@ pub fun test : (xs : list, y : int, z : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat5); val _ : () = std/core/types/.drop(.box); std/core/types/(); diff --git a/test/parc/parc4.kk.out b/test/parc/parc4.kk.out index dfe60e3e5..da0b0fd56 100644 --- a/test/parc/parc4.kk.out +++ b/test/parc/parc4.kk.out @@ -5,7 +5,7 @@ pub fun test : (xs : list>, y : int) -> int = fn(xs: list>, y: int){ match (xs) { (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Just(((.skip std/core/types/.Box((x: int)) : .Box ) as .box: .Box)) : maybe ) as - .pat: maybe)) : .Box ) as .box: .Box), (.pat: list>)) : list> ) + .pat0: maybe)) : .Box ) as .box: .Box), (.pat1: list>)) : list> ) | std/core/(==.1)(x, y) -> val _ : () = std/core/types/.drop(y); val _ : () @@ -13,7 +13,7 @@ pub fun test : (xs : list>, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat1); val _ : int = std/core/types/.dup(x); val _ : () @@ -30,7 +30,7 @@ pub fun test : (xs : list>, y : int) -> int std/core/types/(); }); x; - (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Nothing() : maybe ) as .pat: maybe)) : .Box ) as .box: .Box), (.pat: list< + (std/core/Cons(((.skip std/core/types/.Box(((std/core/types/Nothing() : maybe ) as .pat3: maybe)) : .Box ) as .box: .Box), (.pat4: list< maybe>)) : list> ) -> val _ : () = std/core/types/.drop(y); @@ -39,7 +39,7 @@ pub fun test : (xs : list>, y : int) -> int (std/core/types/True() : bool ) -> val _ : () = val _ : () - = std/core/types/.drop(.pat); + = std/core/types/.drop(.pat4); val _ : () = std/core/types/.drop(.box); std/core/types/(); From 728ba76ebdadbf41a90d83a2683f4e7df65ac14d Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 21 May 2022 07:57:42 -0700 Subject: [PATCH 053/233] clean up options; remove 'opt' prefix --- src/Compiler/Compile.hs | 2 +- src/Compiler/Options.hs | 24 +++++++++++------------- src/Core/CTail.hs | 25 +++++++++---------------- test/cgen/specialize/config.json | 2 +- 4 files changed, 22 insertions(+), 31 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 1003a24a3..1fb4509d9 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -918,7 +918,7 @@ inferCheck loaded0 flags line coreImports program -- tail-call-modulo-cons optimization when (optctail flags) $ - ctailOptimize penv (platform flags) newtypes gamma (optctailInline flags) (optctailContext flags) + ctailOptimize penv newtypes gamma (optctailCtxPath flags) -- transform effects to explicit monadic binding (and resolve .open calls) when (enableMon flags && not (isPrimitiveModule (Core.coreProgName coreProgram))) $ diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index 0a7357296..bae44c658 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -175,8 +175,7 @@ data Flags , optimize :: Int -- optimization level; 0 or less is off , optInlineMax :: Int , optctail :: Bool - , optctailInline :: Bool - , optctailContext :: Bool + , optctailCtxPath :: Bool , parcReuse :: Bool , parcSpecialize :: Bool , parcReuseSpec :: Bool @@ -269,8 +268,7 @@ flagsNull 0 -- optimize 12 -- inlineMax True -- optctail - False -- optctailInline - True -- optctailContext + True -- optctailCtxPath True -- parc reuse True -- parc specialize True -- parc reuse specialize @@ -374,14 +372,13 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , hide $ fnum 10 "n" ["inline"] (\i f -> f{optInlineMax=i}) "set 'n' as maximum inline threshold (=10)" , hide $ fflag ["monadic"] (\b f -> f{enableMon=b}) "enable monadic translation" , hide $ flag [] ["semi"] (\b f -> f{semiInsert=b}) "insert semicolons based on layout" - , hide $ fflag ["binference"] (\b f -> f{parcBorrowInference=b}) "enable reuse inference (does not work cross-module!)" - , hide $ fflag ["optreuse"] (\b f -> f{parcReuse=b}) "enable in-place update analysis" - , hide $ fflag ["optdropspec"] (\b f -> f{parcSpecialize=b}) "enable drop specialization" - , hide $ fflag ["optreusespec"] (\b f -> f{parcReuseSpec=b}) "enable reuse specialization" - , hide $ fflag ["opttrmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" - , hide $ fflag ["opttrmcinline"] (\b f -> f{optctailInline=b}) "enable trmc inlining (increases code size)" - , hide $ fflag ["opttrmcctx"] (\b f -> f{optctailContext=b}) "enable trmc context paths" - , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" + , hide $ fflag ["binference"] (\b f -> f{parcBorrowInference=b}) "enable reuse inference (does not work cross-module!)" + , hide $ fflag ["reuse"] (\b f -> f{parcReuse=b}) "enable in-place update analysis" + , hide $ fflag ["dropspec"] (\b f -> f{parcSpecialize=b}) "enable drop specialization" + , hide $ fflag ["reusespec"] (\b f -> f{parcReuseSpec=b}) "enable reuse specialization" + , hide $ fflag ["trmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" + , hide $ fflag ["trmcctx"] (\b f -> f{optctailCtxPath=b}) "enable trmc context paths" + , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" -- deprecated , hide $ option [] ["cmake"] (ReqArg cmakeFlag "cmd") "use to invoke cmake" @@ -662,7 +659,7 @@ processOptions flags0 opts cdefs = ccompDefs flags ++ if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))] ++ if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")] - ++ if optctailContext flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")] + ++ if optctailCtxPath flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")] -- vcpkg -- (vcpkgRoot,vcpkg) <- vcpkgFindRoot (vcpkgRoot flags) @@ -700,6 +697,7 @@ processOptions flags0 opts else if (optimize flags <= 1) then (optInlineMax flags) `div` 3 else (optInlineMax flags), + optctailCtxPath = (optctailCtxPath flags && isTargetC (target flags)), ccompPath = ccmd, ccomp = cc, diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index b79c3aa55..5809922d9 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -42,14 +42,14 @@ import Core.Pretty -------------------------------------------------------------------------- -- Reference count transformation -------------------------------------------------------------------------- -ctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> CorePhase () -ctailOptimize penv platform newtypes gamma ctailInline useContextPath +ctailOptimize :: Pretty.Env -> Newtypes -> Gamma -> Bool -> CorePhase () +ctailOptimize penv newtypes gamma useContextPath = liftCorePhaseUniq $ \uniq defs -> - runUnique uniq (uctailOptimize penv platform newtypes gamma ctailInline useContextPath defs) + runUnique uniq (uctailOptimize penv newtypes gamma useContextPath defs) -uctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> DefGroups -> Unique DefGroups -uctailOptimize penv platform newtypes gamma ctailInline useContextPath defs - = ctailRun penv platform newtypes gamma ctailInline useContextPath (ctailDefGroups True defs) +uctailOptimize :: Pretty.Env -> Newtypes -> Gamma -> Bool -> DefGroups -> Unique DefGroups +uctailOptimize penv newtypes gamma useContextPath defs + = ctailRun penv newtypes gamma useContextPath (ctailDefGroups True defs) -------------------------------------------------------------------------- -- Definition groups @@ -526,10 +526,8 @@ maybeStats xs expr data Env = Env { currentDef :: [Def], prettyEnv :: Pretty.Env, - platform :: Platform, newtypes :: Newtypes, gamma :: Gamma, - ctailInline :: Bool, ctailName :: TName, ctailSlot :: Maybe TName, isMulti :: Bool, @@ -560,10 +558,10 @@ updateSt = modify getSt :: CTail CTailState getSt = get -ctailRun :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> Bool -> CTail a -> Unique a -ctailRun penv platform newtypes gamma ctailInline useContextPath (CTail action) +ctailRun :: Pretty.Env -> Newtypes -> Gamma -> Bool -> CTail a -> Unique a +ctailRun penv newtypes gamma useContextPath (CTail action) = withUnique $ \u -> - let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True useContextPath False + let env = Env [] penv newtypes gamma (TName nameNil typeUnit) Nothing True useContextPath False st = CTailState u (val, st') = runState (runReaderT action env) st in (val, uniq st') @@ -643,11 +641,6 @@ getPrettyEnv = prettyEnv <$> getEnv withPrettyEnv :: (Pretty.Env -> Pretty.Env) -> CTail a -> CTail a withPrettyEnv f = withEnv (\e -> e { prettyEnv = f (prettyEnv e) }) -getPlatform :: CTail Platform -getPlatform = platform <$> getEnv - -getOptCtailInline :: CTail Bool -getOptCtailInline = ctailInline <$> getEnv --------------------- -- state accessors -- diff --git a/test/cgen/specialize/config.json b/test/cgen/specialize/config.json index 59d92c828..f218417c6 100644 --- a/test/cgen/specialize/config.json +++ b/test/cgen/specialize/config.json @@ -1 +1 @@ -"-e --showhiddentypesigs --fno-opttrmc -O1" +"-e --showhiddentypesigs --fno-trmc -O1" From 0f1b981c5299ec19673eff88cdb4b0f5f46ba323 Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 21 May 2022 07:59:41 -0700 Subject: [PATCH 054/233] fix trmc option in benchmarks --- test/bench/koka/CMakeLists.txt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/bench/koka/CMakeLists.txt b/test/bench/koka/CMakeLists.txt index e4c551b23..4f9001543 100644 --- a/test/bench/koka/CMakeLists.txt +++ b/test/bench/koka/CMakeLists.txt @@ -36,11 +36,11 @@ foreach (source IN LISTS sources) add_executable(${name}-exe IMPORTED) set_target_properties(${name}-exe PROPERTIES IMPORTED_LOCATION "${out_path}") - # --fno-optctail - # --fno-optreuse + # --fno-trmc + # --fno-reuse add_custom_command( OUTPUT ${outx_path} - COMMAND ${koka} --target=c --stack=128M --outputdir=${outx_dir} --buildname=${namex} -v -O2 --fno-opttrmc -i$ "${source}" + COMMAND ${koka} --target=c --stack=128M --outputdir=${outx_dir} --buildname=${namex} -v -O2 --fno-trmc -i$ "${source}" DEPENDS ${source} VERBATIM) From 1e2a25eee85397c3046a3f82b013334e97e29e31 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 08:25:28 -0700 Subject: [PATCH 055/233] fix type of int64 clamp --- lib/std/core/core-integer-inline.js | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/std/core/core-integer-inline.js b/lib/std/core/core-integer-inline.js index de01a6814..8168b021d 100644 --- a/lib/std/core/core-integer-inline.js +++ b/lib/std/core/core-integer-inline.js @@ -118,16 +118,16 @@ export function _int64_from_int32(x) { return BigInt(x); } -const _max_uint32 = 0xFFFFFFFFn; -const _max_int32 = 0x7FFFFFFFn; -const _min_int32 = -0x80000000n; +const _max_uint32n = 0xFFFFFFFFn; +const _max_int32n = 0x7FFFFFFFn; +const _min_int32n = -0x80000000n; export function _int64_clamp_int32(x) { - return (x > _max_int32n ? _max_int32n : (x < _min_int32n ? _min_int32n : Number(x))); + return Number( x > _max_int32n ? _max_int32n : (x < _min_int32n ? _min_int32n : x) ); } export function _int64_clamp_uint32(x) { - return (x > _max_uint32n ? -1 : (x < 0 ? 0 : (x <= _max_int32n ? Number(x) : Number(x) - 0x100000000))); + return Number(x > _max_uint32n ? -1 : (x < 0 ? 0 : (x <= _max_int32n ? x : x - 0x100000000n))); } @@ -595,6 +595,7 @@ export function _int_clamp32(x) { } export function _int_from_int32(x) { + // console.log("int_from_int32: " + x + ": " + typeof x) return x; } From 844be4436a9f1230c728b5b73a8f0c95bd9b4f66 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 09:48:32 -0700 Subject: [PATCH 056/233] clean up ctail code in kklib --- kklib/include/kklib.h | 49 ++++++++++++++++++++++++++++-- kklib/src/refcount.c | 50 +++++++++++++++---------------- lib/std/core/types-ctail-inline.h | 4 ++- src/Backend/C/FromCore.hs | 2 +- 4 files changed, 75 insertions(+), 30 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 4f2ac9fe0..318d4ce4f 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -521,6 +521,15 @@ static inline void kk_free(const void* p, kk_context_t* ctx) { static inline void kk_free_local(const void* p, kk_context_t* ctx) { kk_free(p,ctx); } + +#define KK_HAS_MALLOC_COPY +static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { + const size_t size = mi_usable_size(p); + void* q = mi_heap_malloc(ctx->heap, size); + memcpy(q,p,size); + return q; +} + #else static inline void* kk_malloc(kk_ssize_t sz, kk_context_t* ctx) { kk_unused(ctx); @@ -549,6 +558,28 @@ static inline void kk_free(const void* p, kk_context_t* ctx) { static inline void kk_free_local(const void* p, kk_context_t* ctx) { kk_free(p,ctx); } + +#if defined(__linux__) || defined(__GLIBC__) +#include +#define kk_malloc_usable_size(p) malloc_usable_size(p) +#elif defined(__APPLE__) +#include +#define kk_malloc_usable_size(p) malloc_size(p) +#elif defined(_MSC_VER) +#include +#define kk_malloc_usable_size(p) _msize(p) +#endif + +#if defined(kk_malloc_usable_size) +#define KK_HAS_MALLOC_COPY +#endif + +static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { + const size_t size = kk_malloc_usable_size(p); + void* q = mi_heap_malloc(ctx->heap, size); + memcpy(q,p,size); + return q; +} #endif @@ -1382,8 +1413,22 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { } -kk_decl_export kk_box_t kk_ctail_context_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); -#define kk_ctail_set_context_field(as_tp,x,field_offset) \ +/*-------------------------------------------------------------------------------------- + TRMC (Further primitives are defined in `lib/std/core/types-ctail-inline.h`) +--------------------------------------------------------------------------------------*/ + +#if !defined(KK_HAS_MALLOC_COPY) +#define KK_CTAIL_NO_CONTEXT_PATH +#else + +// functional context composition by copying along the context path and attaching `child` at the hole. +kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); + +// use a macro as `x` can be a datatype or direct pointer; update the field_idx with the field +// that is along the context path, and return `x` as is. +#define kk_ctail_set_context_path(as_tp,x,field_offset) \ (kk_constructor_field_idx_set( as_tp(x), 1 + (field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)), x) +#endif + #endif // include guard diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index e3ae9ebff..1d63408dc 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -571,43 +571,41 @@ kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx) { } } -static kk_ssize_t kk_block_full_size(kk_block_t* b, kk_context_t* ctx) { - kk_unused(ctx); - return kk_to_ssize_t(mi_usable_size(b)); -} +/*-------------------------------------------------------------------------------------- + TRMC: copy a context following the context path indicated in the _field_idx. +--------------------------------------------------------------------------------------*/ +#if defined(KK_HAS_MALLOC_COPY) static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { - kk_ssize_t size = kk_block_full_size(b,ctx); - kk_block_t* c = (kk_block_t*)kk_malloc_small(size,ctx); - memcpy(c,b,size); + kk_block_t* c = (kk_block_t*)kk_malloc_copy(b,ctx); kk_block_refcount_set(c,0); + for( kk_ssize_t i = 0; i < kk_block_scan_fsize(b); i++) { + kk_box_dup(kk_block_field(c, i)); + } return c; } -kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { +kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res))); - kk_box_t cres; - kk_box_t* parent = NULL; - kk_block_t* c; - kk_box_t cur = res; - do { + kk_box_t cres; // copied result context + kk_box_t* next = NULL; // pointer to the context path field in the parent block + for( kk_box_t cur = res; kk_box_is_ptr(cur); cur = *next ) { kk_block_t* b = kk_ptr_unbox(cur); const kk_ssize_t field = kk_block_field_idx(b) - 1; kk_assert_internal(field >= 0); - c = kk_block_alloc_copy(b,ctx); - if (parent == NULL) { cres = kk_ptr_box(c); } - else { *parent = kk_ptr_box(c); } - for( kk_ssize_t i = 0; i < kk_block_scan_fsize(b); i++) { - if (i != field) { - kk_box_dup(kk_block_field(c, i)); - } + kk_block_t* c = kk_block_alloc_copy(b,ctx); + if (next == NULL) { + cres = kk_ptr_box(c); } - parent = kk_block_field_address(c,field); - cur = *parent; + else { + kk_box_drop(*next,ctx); + *next = kk_ptr_box(c); + } + next = kk_block_field_address(c,field); } - while (kk_box_is_ptr(cur)); - kk_assert_internal(parent != NULL); - *parent = child; + kk_assert_internal(next != NULL); + *next = child; kk_box_drop(res,ctx); return cres; -} \ No newline at end of file +} +#endif \ No newline at end of file diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index 5bf7ad87c..6920ba5a9 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -21,10 +21,12 @@ static inline kk_std_core_types__ctail kk_ctail_nil(kk_context_t* ctx) { } // apply a context to a child value +// is_linear is always a constant and set to `true` if the effect is guaranteed linear static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { #if !defined(KK_CTAIL_NO_CONTEXT_PATH) // note: written like this for best codegen; be careful when rewriting. if (kk_likely(acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res))))) { + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); *(acc.hole) = child; // in-place update the hole with the child return acc.res; } @@ -32,7 +34,7 @@ static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t return child; } else { - return kk_ctail_context_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child + return kk_ctail_context_copy_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child } #else if (kk_likely(acc.hole != NULL)) { diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 4ddf9ed50..0ae1a1872 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1862,7 +1862,7 @@ genFieldAddress conVar conName fieldName genFieldSetContext :: TName -> Name -> Name -> Doc genFieldSetContext conVar conName fieldName - = text "kk_ctail_set_context_field" <.> + = text "kk_ctail_set_context_path" <.> tupled [conAsNameX conName, ppName (getName conVar), text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] From ba442862f597fddd422ca887cb0b8188594e1a21 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 09:57:08 -0700 Subject: [PATCH 057/233] update mimalloc --- kklib/mimalloc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index f2b6938d6..cacb387a6 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit f2b6938d64d555f2053612da2e84fcb128bd9116 +Subproject commit cacb387a61df073162064aaf513fcc32be95c983 From 3fd9095b13b1e7b3f47affb4b07e53022d2984c6 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 10:01:43 -0700 Subject: [PATCH 058/233] update kk_malloc_copy --- kklib/include/kklib.h | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 318d4ce4f..57d302acf 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -522,13 +522,7 @@ static inline void kk_free_local(const void* p, kk_context_t* ctx) { kk_free(p,ctx); } -#define KK_HAS_MALLOC_COPY -static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { - const size_t size = mi_usable_size(p); - void* q = mi_heap_malloc(ctx->heap, size); - memcpy(q,p,size); - return q; -} +#define kk_malloc_usable_size(p) mi_usable_size(p) #else static inline void* kk_malloc(kk_ssize_t sz, kk_context_t* ctx) { @@ -570,19 +564,18 @@ static inline void kk_free_local(const void* p, kk_context_t* ctx) { #define kk_malloc_usable_size(p) _msize(p) #endif -#if defined(kk_malloc_usable_size) -#define KK_HAS_MALLOC_COPY #endif +#if defined(kk_malloc_usable_size) +#define KK_HAS_MALLOC_COPY static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { const size_t size = kk_malloc_usable_size(p); - void* q = mi_heap_malloc(ctx->heap, size); + void* q = kk_malloc(kk_to_ssize_t(size), ctx); memcpy(q,p,size); return q; } #endif - static inline void kk_block_init(kk_block_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag) { kk_unused(size); kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); From fe16f7537e6b60bfbfd22142577fbbde96bdf8e7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 10:24:40 -0700 Subject: [PATCH 059/233] renaming for trmc --- kklib/include/kklib.h | 2 +- kklib/mimalloc | 2 +- lib/std/core/types-ctail-inline.h | 8 ++--- lib/std/core/types-ctail-inline.js | 6 ++-- src/Backend/C/FromCore.hs | 12 ++++--- src/Backend/JavaScript/FromCore.hs | 2 ++ src/Common/NamePrim.hs | 19 +++++------ src/Core/CTail.hs | 54 +++++++++++++++--------------- 8 files changed, 54 insertions(+), 51 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 57d302acf..8579bce3e 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 92 // modify on changes to trigger recompilation +#define KKLIB_BUILD 93 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/mimalloc b/kklib/mimalloc index cacb387a6..3d6017de7 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit cacb387a61df073162064aaf513fcc32be95c983 +Subproject commit 3d6017de7c1338bebbb9a4c0e7b8329af202b2e6 diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index 6920ba5a9..f4817e0fd 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -16,13 +16,13 @@ static inline kk_box_t kk_ctail_hole(void) { return kk_intf_box(0); } -static inline kk_std_core_types__ctail kk_ctail_nil(kk_context_t* ctx) { +static inline kk_std_core_types__ctail kk_ctail_unit(kk_context_t* ctx) { return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, ctx); } // apply a context to a child value // is_linear is always a constant and set to `true` if the effect is guaranteed linear -static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { +static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { #if !defined(KK_CTAIL_NO_CONTEXT_PATH) // note: written like this for best codegen; be careful when rewriting. if (kk_likely(acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res))))) { @@ -49,8 +49,8 @@ static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t } // compose a context to a new one -static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { - return kk_std_core_types__new_CTail( kk_ctail_resolve(acc,child,is_linear,ctx), field, ctx ); +static inline kk_std_core_types__ctail kk_ctail_compose( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { + return kk_std_core_types__new_CTail( kk_ctail_apply(acc,child,is_linear,ctx), field, ctx ); } diff --git a/lib/std/core/types-ctail-inline.js b/lib/std/core/types-ctail-inline.js index ff19ac68f..75ef17698 100644 --- a/lib/std/core/types-ctail-inline.js +++ b/lib/std/core/types-ctail-inline.js @@ -5,11 +5,11 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -export function _ctail_nil() { +export function _ctail_unit() { return _CTail(undefined,{value:undefined,field:""}) } -export function _ctail_link(acc,res,field) { +export function _ctail_compose(acc,res,field) { if (acc.res===undefined) { return _CTail(res,field); } @@ -19,7 +19,7 @@ export function _ctail_link(acc,res,field) { } } -export function _ctail_resolve(acc,res) { +export function _ctail_apply(acc,res) { if (acc.res===undefined) { return res; } diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 0ae1a1872..6d027a410 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1791,10 +1791,10 @@ genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conNa doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return (drop,text "(kk_box_t*)" <.> parens doc) --- special: cfield-set-context -genAppNormal (Var cfieldSetContext _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldSetContext == nameCSetContextField +-- special: ctail-set-context-path +genAppNormal (Var ctailSetContextPath _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName ctailSetContextPath == nameCTailSetCtxPath = do (decl,conVar) <- genVarBinding conExpr - let doc = genFieldSetContext conVar (readQualified conName) (readQualified fieldName) + let doc = genCTailSetContextPath conVar (readQualified conName) (readQualified fieldName) return ([decl],doc) -- add/sub small constant @@ -1860,8 +1860,8 @@ genFieldAddress :: TName -> Name -> Name -> Doc genFieldAddress conVar conName fieldName = parens (text "&" <.> conAsNameX (conName) <.> parens (ppName (getName conVar)) <.> text "->" <.> ppName (unqualify fieldName)) -genFieldSetContext :: TName -> Name -> Name -> Doc -genFieldSetContext conVar conName fieldName +genCTailSetContextPath :: TName -> Name -> Name -> Doc +genCTailSetContextPath conVar conName fieldName = text "kk_ctail_set_context_path" <.> tupled [conAsNameX conName, ppName (getName conVar), text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] @@ -2010,9 +2010,11 @@ genExprExternal tname formats [argDoc] | getName tname == nameReuse genExprExternal tname formats [] | getName tname == nameCFieldHole = return ([],ppType (resultType (typeOf tname)) <.> text "_hole()") +{- -- special case: cfield set genExprExternal tname formats [fieldDoc,argDoc] | getName tname == nameCFieldSet = return ([],text "*" <.> parens fieldDoc <+> text "=" <+> argDoc) +-} -- normal external genExprExternal tname formats argDocs0 diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index 6c4c542f3..bfdb1a986 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -915,9 +915,11 @@ genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) genExprExternalPrim tname formats [] | getName tname == nameCFieldHole = return ([],text "undefined") +{- -- special case: cfield-set (field is implemented as {value:, field:}) genExprExternalPrim tname formats [accDoc,resDoc] | getName tname == nameCFieldSet = return ([], tupled [accDoc <.> text ".value[" <.> accDoc <.> text ".field] =" <+> resDoc, text "$std_core_types._Unit_"]) +-} -- normal external genExprExternalPrim tname formats argDocs0 diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index c74baae4c..3b41d4048 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -73,12 +73,12 @@ module Common.NamePrim -- * CTail optimization , nameTpCField, nameTpCTailAcc , nameCFieldHole - , nameCFieldSet + -- , nameCFieldSet , nameCFieldOf - , nameCTailNil - , nameCTailLink - , nameCTailResolve - , nameCSetContextField + , nameCTailUnit + , nameCTailCompose + , nameCTailApply + , nameCTailSetCtxPath -- * Constructors , nameTrue, nameFalse @@ -271,12 +271,11 @@ nameTpBuilder = qualify (newName "std/text/string") (newName "builder") nameTpCTailAcc = cfieldName "ctail" nameTpCField = cfieldName "cfield" nameCFieldHole = cfieldName ".cfield-hole" -nameCFieldSet = cfieldName "cfield-set" -- private (not hidden) nameCFieldOf = cfieldName ".cfield-of" -nameCTailNil = cfieldName ".ctail-nil" -nameCTailLink = cfieldName ".ctail-link" -nameCTailResolve = cfieldName ".ctail-resolve" -nameCSetContextField = cfieldName ".ctail-set-context-field" +nameCTailUnit = cfieldName ".ctail-unit" +nameCTailCompose = cfieldName ".ctail-compose" +nameCTailApply = cfieldName ".ctail-apply" +nameCTailSetCtxPath=cfieldName ".ctail-set-context-path" cfieldName name = coreTypesName name {-------------------------------------------------------------------------- diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 5809922d9..f0b4619c3 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -167,7 +167,7 @@ ctailWrapperBody :: Type -> TName -> Maybe Expr -> [TypeVar] -> [TName] -> CTail ctailWrapperBody resTp slot mbMulti targs args = do tailVar <- getCTailFun let ctailCall = App (makeTypeApp tailVar [TVar tv | tv <- targs]) - ([Var name InfoNone | name <- args] ++ [makeCTailNil resTp]) + ([Var name InfoNone | name <- args] ++ [makeCTailUnit resTp]) case mbMulti of Nothing -> return ctailCall Just ctailMultiVar @@ -246,7 +246,7 @@ ctailExpr top expr case (expr',mbSlot) of (App v@(Var ctailmSlot _) [arg], Just slot) | getName ctailmSlot == getName slot -> return (App v [TypeApp arg targs]) -- push down typeapp - (App v@(TypeApp (Var ctailResolve _) _) [acc,arg],_) | getName ctailResolve == nameCTailResolve + (App v@(TypeApp (Var ctailApply _) _) [acc,arg],_) | getName ctailApply == nameCTailApply -> return (App v [acc,TypeApp arg targs]) -- push down typeapp into ctail set _ -> return (TypeApp expr' targs) @@ -271,7 +271,7 @@ ctailExpr top expr Nothing -> return body Just slot -> do isMulti <- getIsMulti alwaysAffine <- getIsAlwaysAffine - return (makeCTailResolve isMulti alwaysAffine slot body) + return (makeCTailApply isMulti alwaysAffine slot body) handleConApp dname cname fcon fargs = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) @@ -348,7 +348,7 @@ ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) mkAppNew = \args -> do (defs,cexpr) <- mkApp (reverse rargs ++ args) if not useCtxPath then return (defs,cexpr) - else do setfld <- setContextFieldExpr cname field + else do setfld <- setContextPathExpr cname field x <- uniqueTName (typeOf cexpr) y <- uniqueTName (typeOf cexpr) let cexprdef = DefNonRec (makeTDef y cexpr) @@ -363,19 +363,19 @@ ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) if not useCtxPath then do let condef = DefNonRec (makeTDef x (App fcon args)) return ([condef] ++ defs, expr) - else do setfld <- setContextFieldExpr cname field + else do setfld <- setContextPathExpr cname field y <- uniqueTName (typeOf x) let condef = DefNonRec (makeTDef y (App fcon args)) let setdef = DefNonRec (makeTDef x (setfld y)) return ([condef,setdef] ++ defs, expr) -setContextFieldExpr cname field +setContextPathExpr cname field = do fieldInfo <- getFieldName cname field case fieldInfo of Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 Right (_,fieldName) -> - return (\parent -> makeCSetContextField (Var parent InfoNone) cname fieldName) + return (\parent -> makeCSetContextPath (Var parent InfoNone) cname fieldName) @@ -409,8 +409,8 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs (defs,cons) <- mkConsApp [hole] consName <- uniqueTName (typeOf cons) alwaysAffine <- getIsAlwaysAffine - let link = makeCTailLink slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine - ctailCall = mkTailApp ctailVar link -- App ctailVar (fargs ++ [link]) + let comp = makeCTailCompose slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine + ctailCall = mkTailApp ctailVar comp return $ (defs ++ [DefNonRec (makeTDef consName cons)] ,ctailCall) @@ -429,11 +429,11 @@ makeCFieldHole tp -- Initial empty context (@ctx hole) -makeCTailNil :: Type -> Expr -makeCTailNil tp - = App (TypeApp (Var (TName nameCTailNil funType) +makeCTailUnit :: Type -> Expr +makeCTailUnit tp + = App (TypeApp (Var (TName nameCTailUnit funType) -- (InfoArity 1 0) - (InfoExternal [(C CDefault,"kk_ctail_nil(kk_context())"),(JS JsDefault,"$std_core_types._ctail_nil()")]) + (InfoExternal [(C CDefault,"kk_ctail_unit(kk_context())"),(JS JsDefault,"$std_core_types._ctail_unit()")]) ) [tp]) [] where funType = TForall [a] [] (TFun [] typeTotal (TApp typeCTail [TVar a])) @@ -452,13 +452,13 @@ makeCFieldOf objName conName fieldName tp -- Compose two contexts -makeCTailLink :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr -makeCTailLink slot resName objName conName fieldName tp alwaysAffine +makeCTailCompose :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr +makeCTailCompose slot resName objName conName fieldName tp alwaysAffine = let fieldOf = makeCFieldOf objName conName fieldName tp - in App (TypeApp (Var (TName nameCTailLink funType) + in App (TypeApp (Var (TName nameCTailCompose funType) -- (InfoArity 1 3) - (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3," ++ affine ++ ",kk_context())"), - (JS JsDefault,"$std_core_types._ctail_link(#1,#2,#3)")]) + (InfoExternal [(C CDefault,"kk_ctail_compose(#1,#2,#3," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._ctail_compose(#1,#2,#3)")]) ) [tp]) [Var slot InfoNone, Var resName InfoNone, fieldOf] where @@ -470,14 +470,14 @@ makeCTailLink slot resName objName conName fieldName tp alwaysAffine -- Apply a context to its final value. -makeCTailResolve :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr -makeCTailResolve True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve +makeCTailApply :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr +makeCTailApply True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve = App (Var slot InfoNone) [expr] -makeCTailResolve False alwaysAffine slot expr -- slot is a `ctail` - = App (TypeApp (Var (TName nameCTailResolve funType) +makeCTailApply False alwaysAffine slot expr -- slot is a `ctail` + = App (TypeApp (Var (TName nameCTailApply funType) -- (InfoArity 1 2) - (InfoExternal [(C CDefault,"kk_ctail_resolve(#1,#2," ++ affine ++ ",kk_context())"), - (JS JsDefault,"$std_core_types._ctail_resolve(#1,#2)")]) + (InfoExternal [(C CDefault,"kk_ctail_apply(#1,#2," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._ctail_apply(#1,#2)")]) ) [tp]) [Var slot InfoNone, expr] where @@ -489,9 +489,9 @@ makeCTailResolve False alwaysAffine slot expr -- slot is a `ctail` -- Set the index of the field in a constructor to follow the path to the hole at runtime. -makeCSetContextField :: Expr -> TName -> Name -> Expr -makeCSetContextField obj conName fieldName - = App (Var (TName nameCSetContextField funType) (InfoExternal [(Default,".cfield-set-context(#1,#2,#3)")])) +makeCSetContextPath :: Expr -> TName -> Name -> Expr +makeCSetContextPath obj conName fieldName + = App (Var (TName nameCTailSetCtxPath funType) (InfoExternal [(Default,".ctail-set-context-path(#1,#2,#3)")])) [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] where tp = typeOf obj From 08ac3fa6d5e4264c90282e8cb23912cb663e8fb4 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 10:30:32 -0700 Subject: [PATCH 060/233] cleanup --- kklib/src/refcount.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 1d63408dc..04846085c 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -584,7 +584,9 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { } return c; } +#endif +#if !defined(KK_CTAIL_NO_CONTEXT_PATH) kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res))); kk_box_t cres; // copied result context @@ -608,4 +610,4 @@ kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t kk_box_drop(res,ctx); return cres; } -#endif \ No newline at end of file +#endif From a6a36ed57e58ae48a36ef74be6db8d7ea3c0516e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 21 May 2022 12:48:22 -0700 Subject: [PATCH 061/233] improve reno sub performance --- kklib/include/kklib/integer.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 7dd825382..28989965e 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -670,7 +670,7 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t } static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if 0 + #if 1 kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); if (kk_unlikely(!kk_is_smallint(y) || kk_not_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); //if (kk_unlikely(!kk_is_smallint(y))) return kk_integer_add_generic(x,y,ctx); From dc3163d490ca3a8eaa09a8972cc902b4adce74ff Mon Sep 17 00:00:00 2001 From: Daan Date: Tue, 24 May 2022 11:02:12 -0700 Subject: [PATCH 062/233] more ctail testing --- kklib/mimalloc | 2 +- test/cgen/ctail9.kk | 11 +++++++++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index 3d6017de7..f2b6938d6 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit 3d6017de7c1338bebbb9a4c0e7b8329af202b2e6 +Subproject commit f2b6938d64d555f2053612da2e84fcb128bd9116 diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk index c25256703..675f1bfdb 100644 --- a/test/cgen/ctail9.kk +++ b/test/cgen/ctail9.kk @@ -1,15 +1,22 @@ -fun mapx( xs : list, f : a -> e b ) : e list { +fun mapxx( xs : list, f : a -> e b ) : e list { match(xs) { - Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Cons(x,xx) -> Cons(f(x),xx.mapxx(f)) Nil -> Nil } } +fun mapx( xs : list, f : a -> e b ) : e list { + match(xs) { + Nil -> Nil + _ -> xs.mapxx(f) + } +} fun test(n : int) { val xs = list(1,n) val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) + // acc + xs.mapxx(fn(x){ x+1 }).sum acc + xs.mapx(fn(x){ x+1 }).sum println("total: " ++ x.show) } From 96c8cfa2ea9ca25020b50fb36139d1379256fada Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Tue, 24 May 2022 20:27:37 +0200 Subject: [PATCH 063/233] Add tmap as ctail10 test --- test/cgen/ctail10.kk | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 test/cgen/ctail10.kk diff --git a/test/cgen/ctail10.kk b/test/cgen/ctail10.kk new file mode 100644 index 000000000..7e7057161 --- /dev/null +++ b/test/cgen/ctail10.kk @@ -0,0 +1,32 @@ +type tree + Bin(l : tree, x : a, r : tree) + Tip + +fun tree(n : int) + if n <= 0 + then Tip + else + val m = n - 1 + val l = tree( m / 2 ) + val r = tree( m - m / 2 ) + Bin(l, n, r) + +fun tmap(t : tree, f : a -> e b) : e tree + match t + Tip -> Tip + Bin(l, x, r) -> Bin(l.tmap(f), f(x), r.tmap(f)) + +fun tsum(t : tree) : div int + tsum'(t, 0) + +fun tsum'(t : tree, acc : int) : div int + match t + Tip -> acc + Bin(l, x, r) -> tsum'(l, tsum'(r, acc + x)) + +fun test(n : int) + val xs = tree(n) + val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) + // acc + xs.mapxx(fn(x){ x+1 }).sum + acc + xs.tmap(fn(x){ x+1 }).tsum + println("total: " ++ x.show) \ No newline at end of file From 7534e5eb739d16240abc519345d2b093b01ff94c Mon Sep 17 00:00:00 2001 From: Daan Date: Tue, 24 May 2022 11:55:08 -0700 Subject: [PATCH 064/233] fix ATOMIC_VAR_INIT warnings; fix --kktime flag for wasm target --- kklib/include/kklib.h | 4 ++-- kklib/include/kklib/atomic.h | 7 +++++++ src/Compiler/Compile.hs | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 8579bce3e..96a2a7f22 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -124,8 +124,8 @@ typedef struct kk_header_s { } kk_header_t; #define KK_SCAN_FSIZE_MAX (0xFF) -#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, ATOMIC_VAR_INIT(0) } // start with refcount of 0 -#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, ATOMIC_VAR_INIT(KK_U32(0x80000000)) } // start with a stuck refcount (RC_STUCK) +#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with refcount of 0 +#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(KK_U32(0x80000000)) } // start with a stuck refcount (RC_STUCK) static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_t tag) { kk_assert_internal(scan_fsize >= 0 && scan_fsize <= KK_SCAN_FSIZE_MAX); diff --git a/kklib/include/kklib/atomic.h b/kklib/include/kklib/atomic.h index f60c7c01b..bd145e7fb 100644 --- a/kklib/include/kklib/atomic.h +++ b/kklib/include/kklib/atomic.h @@ -25,6 +25,13 @@ #define kk_memory_order_t memory_order #endif +// ATOMIC_VAR_INIT is deprecated in C17 and C++20 +#if (__cplusplus >= 201803L || __STDC_VERSION__ >= 201710L) +#define KK_ATOMIC_VAR_INIT(x) x +#else +#define KK_ATOMIC_VAR_INIT(x) ATOMIC_VAR_INIT(x) +#endif + #define kk_atomic_load_relaxed(p) kk_atomic(load_explicit)(p,kk_memory_order(relaxed)) #define kk_atomic_load_acquire(p) kk_atomic(load_explicit)(p,kk_memory_order(acquire)) #define kk_atomic_store_relaxed(p,x) kk_atomic(store_explicit)(p,x,kk_memory_order(relaxed)) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 1fb4509d9..24e28946e 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -1306,7 +1306,7 @@ codeGenC sourceFile newtypes borrowed0 unique0 term flags modules compileTarget case target flags of C Wasm -> do return (Just (mainTarget, - runSystemEcho term flags (wasmrun flags ++ " " ++ dquote mainTarget ++ cmdflags ++ " " ++ execOpts flags))) + runSystemEcho term flags (wasmrun flags ++ " " ++ dquote mainTarget ++ " -- " ++ cmdflags ++ " " ++ execOpts flags))) C WasmWeb -> do return (Just (mainTarget, runSystemEcho term flags (dquote mainTarget ++ " &"))) C WasmJs From ec55258c5f8a1643bdd56c31cafcb7c4e2be321a Mon Sep 17 00:00:00 2001 From: daan Date: Tue, 24 May 2022 21:13:44 -0700 Subject: [PATCH 065/233] small edits --- kklib/include/kklib.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 8579bce3e..73ba7b92a 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1418,9 +1418,9 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); // use a macro as `x` can be a datatype or direct pointer; update the field_idx with the field -// that is along the context path, and return `x` as is. +// index + 1 that is along the context path, and return `x` as is. #define kk_ctail_set_context_path(as_tp,x,field_offset) \ - (kk_constructor_field_idx_set( as_tp(x), 1 + (field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)), x) + (kk_constructor_field_idx_set( as_tp(x), 1 + ((field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)) ), x) #endif From 031e152e4f1a76b2f275732877ad79363cdfcc4b Mon Sep 17 00:00:00 2001 From: daan Date: Tue, 24 May 2022 22:25:12 -0700 Subject: [PATCH 066/233] small changes to ctail; slightly faster --- kklib/mimalloc | 2 +- lib/std/core/types-ctail-inline.h | 13 +++++++------ test/cgen/ctail10.kk | 14 ++++++++++---- test/cgen/ctail9.kk | 4 ++-- 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index f2b6938d6..3d6017de7 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit f2b6938d64d555f2053612da2e84fcb128bd9116 +Subproject commit 3d6017de7c1338bebbb9a4c0e7b8329af202b2e6 diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index f4817e0fd..6faa8f5db 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -23,21 +23,22 @@ static inline kk_std_core_types__ctail kk_ctail_unit(kk_context_t* ctx) { // apply a context to a child value // is_linear is always a constant and set to `true` if the effect is guaranteed linear static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { - #if !defined(KK_CTAIL_NO_CONTEXT_PATH) // note: written like this for best codegen; be careful when rewriting. - if (kk_likely(acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res))))) { + #if !defined(KK_CTAIL_NO_CONTEXT_PATH) + if (acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res)))) { // no kk_likely seem slightly better kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); *(acc.hole) = child; // in-place update the hole with the child return acc.res; } - else if (acc.hole == NULL) { + else if (kk_likely(acc.hole == NULL)) { return child; } else { - return kk_ctail_context_copy_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child + kk_assert_internal(!is_linear && !kk_block_is_unique(kk_ptr_unbox(acc.res))); + return (is_linear ? kk_intf_box(0) : kk_ctail_context_copy_compose(acc.res,child,ctx)); // copy the context path to the hole and compose with the child } #else - if (kk_likely(acc.hole != NULL)) { + if (acc.hole != NULL) { kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); *(acc.hole) = child; return acc.res; @@ -50,7 +51,7 @@ static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t ch // compose a context to a new one static inline kk_std_core_types__ctail kk_ctail_compose( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { - return kk_std_core_types__new_CTail( kk_ctail_apply(acc,child,is_linear,ctx), field, ctx ); + return kk_std_core_types__new_CTail( kk_ctail_apply(acc,child,is_linear,ctx), field, ctx ); } diff --git a/test/cgen/ctail10.kk b/test/cgen/ctail10.kk index 7e7057161..1900b0d4e 100644 --- a/test/cgen/ctail10.kk +++ b/test/cgen/ctail10.kk @@ -13,8 +13,14 @@ fun tree(n : int) fun tmap(t : tree, f : a -> e b) : e tree match t - Tip -> Tip Bin(l, x, r) -> Bin(l.tmap(f), f(x), r.tmap(f)) + Tip -> Tip + + +fun tmap1(t : tree, f : a -> e b) : e tree + match t + Tip -> Tip + _ -> tmap(t,f) fun tsum(t : tree) : div int tsum'(t, 0) @@ -25,8 +31,8 @@ fun tsum'(t : tree, acc : int) : div int Bin(l, x, r) -> tsum'(l, tsum'(r, acc + x)) fun test(n : int) - val xs = tree(n) + val t = tree(n) val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) - // acc + xs.mapxx(fn(x){ x+1 }).sum - acc + xs.tmap(fn(x){ x+1 }).tsum + acc + t.tmap(fn(x){ x+1 }).tsum + //acc + t.tmap1(fn(x){ x+1 }).tsum println("total: " ++ x.show) \ No newline at end of file diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk index 675f1bfdb..571c7104f 100644 --- a/test/cgen/ctail9.kk +++ b/test/cgen/ctail9.kk @@ -16,8 +16,8 @@ fun mapx( xs : list, f : a -> e b ) : e list { fun test(n : int) { val xs = list(1,n) val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) - // acc + xs.mapxx(fn(x){ x+1 }).sum - acc + xs.mapx(fn(x){ x+1 }).sum + acc + xs.mapxx(fn(x){ x+1 }).sum + //acc + xs.mapx(fn(x){ x+1 }).sum println("total: " ++ x.show) } From d0573e2bbabbe083e426d3bf9bacc0782f429d7c Mon Sep 17 00:00:00 2001 From: daan Date: Wed, 25 May 2022 16:35:25 -0700 Subject: [PATCH 067/233] fix short-circuit issue #270 --- src/Type/Infer.hs | 28 +++++++++++++++++----------- test/cgen/shortcircuit1.kk | 23 +++++++++++++++++++++++ test/cgen/shortcircuit1.kk.out | 4 ++++ 3 files changed, 44 insertions(+), 11 deletions(-) create mode 100644 test/cgen/shortcircuit1.kk create mode 100644 test/cgen/shortcircuit1.kk.out diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index 145df746f..224ba65df 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -1408,9 +1408,13 @@ inferApp propagated expect fun nargs rng topEff <- inferUnifies (checkEffect rng) ((getRange fun, eff1) : effArgs) inferUnify (checkEffectSubsume rng) (getRange fun) funEff topEff + let appexpr = case shortCircuit fcore coreArgs of + Just cexpr -> cexpr + Nothing -> Core.App fcore coreArgs + -- instantiate or generalize result type resTp1 <- subst expTp - (resTp,resCore) <- maybeInstantiateOrGeneralize rng (getRange fun) topEff expect resTp1 (Core.App fcore coreArgs) + (resTp,resCore) <- maybeInstantiateOrGeneralize rng (getRange fun) topEff expect resTp1 appexpr return (resTp,topEff,resCore ) fst3 (x,y,z) = x @@ -2231,19 +2235,21 @@ usesLocalsOp lvars b = usesLocals lvars (hbranchExpr b) shortCircuit :: Core.Expr -> [Core.Expr] -> Maybe Core.Expr shortCircuit fun [expr1,expr2] - = case fun of - Core.App (Core.TypeApp (Core.Var open _) _) [Core.Var name _] | Core.getName open == nameEffectOpen && Core.getName name == nameAnd - -> exprAnd - Core.App (Core.TypeApp (Core.Var open _) _) [Core.Var name _] | Core.getName open == nameEffectOpen && Core.getName name == nameOr - -> exprOr - Core.Var name _ | Core.getName name == nameAnd - -> exprAnd - Core.Var name _ | Core.getName name == nameOr - -> exprOr - _ -> Nothing + = isAndOr fun where exprAnd = Just (Core.makeIfExpr expr1 expr2 Core.exprFalse) exprOr = Just (Core.makeIfExpr expr1 Core.exprTrue expr2) + isAndOr expr + = case expr of + Core.App (Core.TypeApp (Core.Var open _) _) [body] | Core.getName open == nameEffectOpen + -> isAndOr body + Core.Var name _ | Core.getName name == nameAnd + -> exprAnd + Core.Var name _ | Core.getName name == nameOr + -> exprOr + _ -> Nothing + + shortCircuit fun args = Nothing \ No newline at end of file diff --git a/test/cgen/shortcircuit1.kk b/test/cgen/shortcircuit1.kk new file mode 100644 index 000000000..457be00c6 --- /dev/null +++ b/test/cgen/shortcircuit1.kk @@ -0,0 +1,23 @@ +effect choose + ctl flip() : bool + +fun mystery() : bool + val b = flip() + println("b = " ++ b.show) + b + +// is `mystery` ever true? +fun satisfiable-no-short-circuit() : bool + with ctl flip() + // for each input flip(), try both values + ( (resume(True) || resume(False)) : bool ) + mystery() + +fun satisfiable-short-circuit() : bool + with ctl flip() + (resume(True) : bool) || resume(False) + mystery() + +fun main() + satisfiable-no-short-circuit().println + satisfiable-short-circuit().println diff --git a/test/cgen/shortcircuit1.kk.out b/test/cgen/shortcircuit1.kk.out new file mode 100644 index 000000000..42048c21f --- /dev/null +++ b/test/cgen/shortcircuit1.kk.out @@ -0,0 +1,4 @@ +b = True +True +b = True +True \ No newline at end of file From 9067ec27384892e71f985cca731ce1169d0767da Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 27 May 2022 14:58:20 -0700 Subject: [PATCH 068/233] add unix sample --- samples/handlers/nim.kk | 1 + samples/handlers/scoped.kk | 1 + samples/handlers/unix.kk | 88 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 90 insertions(+) create mode 100644 samples/handlers/unix.kk diff --git a/samples/handlers/nim.kk b/samples/handlers/nim.kk index 59ea7d475..363a6b2fe 100644 --- a/samples/handlers/nim.kk +++ b/samples/handlers/nim.kk @@ -1,5 +1,6 @@ /* Examples from the paper "Liberating effects with rows and handlers" by Daniel Hillerström and Sam Lindley. + */ module nim diff --git a/samples/handlers/scoped.kk b/samples/handlers/scoped.kk index e5df71d07..349cb9f23 100644 --- a/samples/handlers/scoped.kk +++ b/samples/handlers/scoped.kk @@ -1,5 +1,6 @@ /* Examples from the paper "Effect handlers in Scope" by Nicolas Wu, Tom Schrijvers, and Ralf Hinze + */ effect nondet diff --git a/samples/handlers/unix.kk b/samples/handlers/unix.kk new file mode 100644 index 000000000..f6707b8f8 --- /dev/null +++ b/samples/handlers/unix.kk @@ -0,0 +1,88 @@ +// Based on Daniel Hillerström PhD Thesis, +// "Foundations for Programming and Implementing Effect Handlers" (chap. 2) +// +// +// which is based on +// +// "The UNIX Time- Sharing System" by Dennis M. Ritchie and Ken Thompson +// https://dsf.berkeley.edu/cs262/unix.pdf + + +// ----------------------------------------- +// Basic I/O +// Shows output state (writer monad) + +effect bio // basic I/O + fun write( fd : filedesc, s : string ) : () + +alias filedesc = int + +val stdout = 0 + +fun echo( s : string ) : bio () + write(stdout,s) + +fun bio( action : () -> a ) : e (a,string) + var buf := "" + with return(x) (x,buf) + with fun write(fd,s) buf := buf ++ s + action() + +fun example1() + with bio + echo("hi ") + echo("unix world") + + +// ----------------------------------------- +// Exit +// Show non-linear control by exiting a computation. (exception monad) + +effect exit + ctl exit( exitcode : int ) : a + +fun status( action : () -> a ) : e int + with ctl exit(code) code + action() + 0 + +fun example2() : (int,string) + with bio + with status + echo("hi ") + exit(1) + echo("unix world") + + +// ----------------------------------------- +// User environment +// Show dynamic binding (reader monad) + +type user + Root + Alice + Bob + +effect whoami + fun whoami() : string + +fun env( user : user, action : () -> a ) : e a + with fun whoami() match user + Root -> "root" + Alice -> "alice" + Bob -> "bob" + action() + +fun example3() + with bio + with status + with env(Alice) + echo("hi ") + echo(whoami()) + + +fun show( (_,s) : ((),string) ) : string + show(s) + +fun show( (i,s) : (int,string) ) : string + "exit with status " ++ i.show ++ "\n" ++ show(s) From 626379925f5997f84f94ab040e9af7d094f56c62 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Sat, 28 May 2022 17:50:00 +0200 Subject: [PATCH 069/233] Fix refcount bug --- src/Backend/C/Parc.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 015bbef6d..5e7bd580a 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -253,8 +253,8 @@ parcGuard scrutinees pats live (Guard test expr) test' <- withOwned S.empty $ parcExpr test return $ \liveInSomeBranch -> scoped pvs $ extendOwned ownedPvs $ extendShapes shapes $ do let dups = S.intersection ownedPvs liveInThisBranch - let drops = liveInSomeBranch \\ liveInThisBranch - Guard test' <$> parcGuardRC dups drops expr' + drops <- filterM isOwned (S.toList $ liveInSomeBranch \\ liveInThisBranch) + Guard test' <$> parcGuardRC dups (S.fromList drops) expr' type Dups = TNames type Drops = TNames From 49a18b2625a96a41885d069be5563531b1031856 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 28 May 2022 18:04:28 -0700 Subject: [PATCH 070/233] update docker bench file --- test/bench/Dockerfile | 61 ++++-- test/bench/bench.kk | 90 ++++----- test/bench/readme-icfp22.txt.md | 120 ++++++++++++ test/bench/run.kk | 318 -------------------------------- 4 files changed, 208 insertions(+), 381 deletions(-) create mode 100644 test/bench/readme-icfp22.txt.md delete mode 100644 test/bench/run.kk diff --git a/test/bench/Dockerfile b/test/bench/Dockerfile index d5b3e8455..ec8eb155d 100644 --- a/test/bench/Dockerfile +++ b/test/bench/Dockerfile @@ -13,37 +13,62 @@ RUN apt-get install -y --no-install-recommends ca-certificates RUN apt-get install -y --no-install-recommends cmake make RUN apt-get install -y --no-install-recommends git RUN apt-get install -y --no-install-recommends gcc libc-dev -RUN apt-get install -y --no-install-recommends ghc ocaml -RUN apt-get install -y --no-install-recommends ghc ocaml RUN apt-get install -y --no-install-recommends curl xz-utils gnupg netbase zlib1g-dev RUN apt-get install -y --no-install-recommends build-essential tar RUN rm -rf /var/lib/apt/lists/* + +# Swift WORKDIR /build -RUN curl -sSL https://get.haskellstack.org/ | sh -RUN git clone --recursive https://github.com/koka-lang/koka -b v2.1.1 -WORKDIR /build/koka -RUN stack build -RUN stack exec koka -- util/bundle -- --postfix=docker -RUN util/install.sh -f -b bundle/koka-docker.tar.gz -WORKDIR /build -RUN curl -O https://swift.org/builds/swift-5.3.3-release/ubuntu2004/swift-5.3.3-RELEASE/swift-5.3.3-RELEASE-ubuntu20.04.tar.gz -RUN tar -xzf swift-5.3.3-RELEASE-ubuntu20.04.tar.gz -WORKDIR /build/swift-5.3.3-RELEASE-ubuntu20.04/usr +RUN curl -O https://download.swift.org/swift-5.6.1-release/ubuntu2004/swift-5.6.1-RELEASE/swift-5.6.1-RELEASE-ubuntu20.04.tar.gz +RUN tar -xzf swift-5.6.1-RELEASE-ubuntu20.04.tar.gz +WORKDIR /build/swift-5.6.1-RELEASE-ubuntu20.04/usr RUN mkdir /opt/swift RUN cp -r * /opt/swift + +# Java WORKDIR /build RUN apt-get update RUN apt-get install -y --no-install-recommends software-properties-common RUN add-apt-repository ppa:linuxuprising/java -RUN echo debconf shared/accepted-oracle-license-v1-2 select true | debconf-set-selections -RUN echo debconf shared/accepted-oracle-license-v1-2 seen true | debconf-set-selections -RUN apt-get install -y --no-install-recommends oracle-java15-installer -RUN apt-get install -y --no-install-recommends oracle-java15-set-default +RUN echo debconf shared/accepted-oracle-license-v1-3 select true | debconf-set-selections +RUN echo debconf shared/accepted-oracle-license-v1-3 seen true | debconf-set-selections +RUN apt-get install -y --no-install-recommends oracle-java17-installer +RUN apt-get install -y --no-install-recommends oracle-java17-set-default RUN apt-get install -y --no-install-recommends libedit2 libz3-dev RUN apt-get install -y --no-install-recommends time + +# Haskell +WORKDIR /build +RUN apt-get install -y --no-install-recommends ghc cabal-install +RUN cabal update +RUN cabal install parallel + +# OCaml (multicore) +WORKDIR /build +RUN apt-get install -y --no-install-recommends opam +RUN opam init -y --disable-sandboxing +RUN opam update -y +RUN opam switch -y create 4.14.0 --repositories=multicore=git+https://github.com/ocaml-multicore/multicore-opam.git,default + +# Stack +WORKDIR /build +RUN curl -sSL https://get.haskellstack.org/ | sh +RUN git clone --recursive https://github.com/koka-lang/koka -b v2.4.1-artifact + +# Koka +WORKDIR /build/koka +RUN stack build +RUN apt-get install -y --no-install-recommends pcre2-utils +RUN stack exec koka -- -e util/bundle -- --postfix=docker +RUN util/install.sh -f -b bundle/v2.4.1/koka-docker.tar.gz + +# Benchmarks WORKDIR /build/koka/test/bench RUN mkdir build WORKDIR /build/koka/test/bench/build RUN cmake .. -DCMAKE_BUILD_TYPE=Release -RUN cmake --build . -RUN echo "ulimit -s unlimited" >> ~/.bashrc \ No newline at end of file + +SHELL ["/bin/bash", "-c"] +RUN eval $(opam env) && cmake --build . +RUN echo "ulimit -s unlimited" >> ~/.bashrc +RUN opam env >> ~/.bashrc diff --git a/test/bench/bench.kk b/test/bench/bench.kk index 16affbae6..67ac1ef29 100644 --- a/test/bench/bench.kk +++ b/test/bench/bench.kk @@ -6,7 +6,7 @@ // Benchmark script // ---------------------------------------------------- -import std/num/double +import std/num/float64 import std/os/file import std/os/path import std/os/env @@ -66,7 +66,7 @@ fun flag-usage() { ].unlines) } -public fun process-flags() : maybe { +pub fun process-flags() : maybe { val (flags,args,errs) = parse( Iflags(), flag-descs, get-args() ) if (flags.help) then { flag-usage() @@ -90,17 +90,17 @@ public fun process-flags() : maybe { struct test { name: string lang: string - elapsed: double = 0.0 - elapsed-sdev : double = 0.0 + elapsed: float64 = 0.0 + elapsed-sdev : float64 = 0.0 rss: int = 0 err: string = "" - norm-elapsed: double = 0.0 - norm-rss: double = 0.0 - norm-elapsed-sdev : double = 0.0 + norm-elapsed: float64 = 0.0 + norm-rss: float64 = 0.0 + norm-elapsed-sdev : float64 = 0.0 } -fun rss-double(t : test) : double { - t.rss.double +fun rss-float64(t : test) : float64 { + t.rss.float64 } fun show( test : test ) { @@ -122,7 +122,7 @@ fun show-norm( test : test ) { // ---------------------------------------------------- // main // ---------------------------------------------------- -public fun main() +pub fun main() match (process-flags()) Nothing -> () Just(flags) -> @@ -167,7 +167,7 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen val ntests = tests.map fn(t) { val norm = if (koka.elapsed==0.0) then 1.0 else t.elapsed / koka.elapsed t(norm-elapsed = norm, - norm-rss = if (koka.rss==0) then 1.0 else t.rss.double / koka.rss.double, + norm-rss = if (koka.rss==0) then 1.0 else t.rss.float64 / koka.rss.float64, norm-elapsed-sdev = norm * t.elapsed-sdev) } println("\n--- normalized " ++ test-name ++ " ----------------") @@ -184,13 +184,13 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen // emit latex chart if (gen-chart) then { val ymax = 3.0 - val chart-desc = @"16-core AMD 5950X at 3.4Ghz\\Ubuntu 20.04, gcc 9.3.0" + val chart-desc = r"16-core AMD 5950X at 3.4Ghz\\Ubuntu 20.04, gcc 9.3.0" val chart-elapsed = if (normalize) then chart("time", True, norm-elapsed, norm-elapsed-sdev, elapsed, test-names, lang-ntests, ymax, chart-desc) else chart("time", False, elapsed, elapsed-sdev, elapsed, test-names, lang-ntests, ymax, chart-desc) val chart-rss = if (True || normalize) - then chart("rss", True, norm-rss, fn(t){ 0.0 }, rss-double, test-names, lang-ntests, ymax, chart-desc) - else chart("rss", False, rss-double, fn(t){ 0.0 }, rss-double, test-names, lang-ntests, ymax, chart-desc) + then chart("rss", True, norm-rss, fn(t){ 0.0 }, rss-float64, test-names, lang-ntests, ymax, chart-desc) + else chart("rss", False, rss-float64, fn(t){ 0.0 }, rss-float64, test-names, lang-ntests, ymax, chart-desc) println("\n") println(chart-elapsed) println("\n") @@ -203,7 +203,7 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen // ---------------------------------------------------- // Latex chart // ---------------------------------------------------- -fun chart( kind : string, normalize : bool, norm : test -> double, norm-sdev : test -> double, abs : test -> double, test-names : list, lang-ntests : list<(string,list)>, ymax : double = 2.0, desc : string = "" ) : string { +fun chart( kind : string, normalize : bool, norm : test -> float64, norm-sdev : test -> float64, abs : test -> float64, test-names : list, lang-ntests : list<(string,list)>, ymax : float64 = 2.0, desc : string = "" ) : string { [ tikz-header(test-names,".bench" ++ kind) , lang-ntests.flatmap(fn(l){ tikz-data(kind, normalize, norm, norm-sdev, abs, l, ymax = ymax ) }) , tikz-picture(kind, normalize, test-names, lang-ntests.map(fst), ymax = ymax, desc = desc ) @@ -222,32 +222,32 @@ fun tikz-footer( test-names : list ) : list { [ "~ End Snippet" ] } -fun tikz-picture( kind : string, normalize : bool, test-names : list, lang-names : list, ymax : double = 5.0, +fun tikz-picture( kind : string, normalize : bool, test-names : list, lang-names : list, ymax : float64 = 5.0, desc : string = "", height:string = "5cm", width:string = "6cm" ) { val n = test-names.length - 1 val header = [ - @"", - @"\begin{tikzpicture}\sffamily", - @"\begin{axis}[Chart" ++ (if (normalize) then "norm" else "abs") ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", - if (normalize) then @" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" else "" + r"", + r"\begin{tikzpicture}\sffamily", + r"\begin{axis}[Chart" ++ (if (normalize) then "norm" else "abs") ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", + if (normalize) then r" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" else "" ] - val mid = lang-names.map(fn(l){ @" \draw" ++ kind ++ @"{color" ++ l ++ @"}{\data" ++ kind ++ l ++ "};"}) + val mid = lang-names.map(fn(l){ r" \draw" ++ kind ++ r"{color" ++ l ++ r"}{\data" ++ kind ++ l ++ "};"}) val footer = [ - if (kind=="time") then @" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" + if (kind=="time") then r" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" else "", - // if (desc.is-empty) then "" else @" \chartdesc{" ++ desc.replace-all("\n",@"\\") ++ "};", - @"\end{axis}", - @"\end{tikzpicture}" + // if (desc.is-empty) then "" else r" \chartdesc{" ++ desc.replace-all("\n",r"\\") ++ "};", + r"\end{axis}", + r"\end{tikzpicture}" ] (header ++ mid ++ footer) } -fun tikz-data( kind:string, normalize : bool, norm : test -> double, norm-sdev : test -> double, abs : test -> double, lang-ntests : (string,list), ymax : double = 5.0 ) : list { +fun tikz-data( kind:string, normalize : bool, norm : test -> float64, norm-sdev : test -> float64, abs : test -> float64, lang-ntests : (string,list), ymax : float64 = 5.0 ) : list { val (lang,ntests) = lang-ntests ["", - @"\pgfplotstableread{", - @"x y y-error meta"] ++ + r"\pgfplotstableread{", + r"x y y-error meta"] ++ ntests.map-indexed(fn(i:int,t:test){ val tval = if (normalize) then t.norm else t.abs if (t.err.is-empty) then { @@ -258,39 +258,39 @@ fun tikz-data( kind:string, normalize : bool, norm : test -> double, norm-sdev : then (if (normalize) then ( if (lang == "kk") then (if (kind=="rss") - then @"{\absrssnormlabel{" ++ (t.abs / 1024.0).round.int.show ++ "mb}}" // megabytes - else @"{\absnormlabel{" ++ t.abs.show-fixed(2) ++ "}}" ) - else @"{\normlabel{" ++ t.norm.show-fixed(2) ++ "}}" ) - else @"{\abslabel{" ++ t.abs.show-fixed(2) ++ "}}") + then r"{\absrssnormlabel{" ++ (t.abs / 1024.0).round.int.show ++ "mb}}" // megabytes + else r"{\absnormlabel{" ++ t.abs.show-fixed(2) ++ "}}" ) + else r"{\normlabel{" ++ t.norm.show-fixed(2) ++ "}}" ) + else r"{\abslabel{" ++ t.abs.show-fixed(2) ++ "}}") else (if (normalize) - then (@"{\outernormlabel{" ++ t.norm.show(2) ++ "}}") - else (@"{\outerlabel{" ++ t.abs.show(2) ++ "}}")) + then (r"{\outernormlabel{" ++ t.norm.show(2) ++ "}}") + else (r"{\outerlabel{" ++ t.abs.show(2) ++ "}}")) ].join(" ") } - else "" // ("" ++ i.show ++ @" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else @"{\ensuremath{\times}}")) + else "" // ("" ++ i.show ++ r" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else r"{\ensuremath{\times}}")) }) ++ - [@"}\data" ++ kind ++ lang] + [r"}\data" ++ kind ++ lang] } // ---------------------------------------------------- // Run a single test // ---------------------------------------------------- -fun insert(xs:list, y :double) : list { +fun insert(xs:list, y :float64) : list { match(xs) { Cons(x,xx) | y > x -> Cons(x,xx.insert(y)) _ -> Cons(y,xs) } } -fun sort(xs : list ) : list { +fun sort(xs : list ) : list { match(xs) { Cons(x,xx) -> xx.sort.insert(x) Nil -> Nil } } -fun median( xs : list ) : double { +fun median( xs : list ) : float64 { val n = xs.length val ys = xs.sort match(ys.drop(n/2 - 1)) { @@ -341,8 +341,8 @@ fun run-test( test-name : string, langt : (string,string), iterations : int ) : } val melapsed = results.map(elapsed).median - val mrss = results.map(fn(t){ t.rss.double }).median.int - val sdev = sqrt( results.map( fn(t){ sqr(t.elapsed - melapsed) } ).sum / results.length.double ) + val mrss = results.map(fn(t){ t.rss.float64 }).median.int + val sdev = sqrt( results.map( fn(t){ sqr(t.elapsed - melapsed) } ).sum / results.length.float64 ) // println("melapsed: " ++ melapsed.show ++ ", mrss: " ++ mrss.show ++ "k") Test(test-name, lang, elapsed=melapsed, rss=mrss, elapsed-sdev=sdev) @@ -352,7 +352,7 @@ fun test-sum( t1 : test, t2 : test) : test { t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) } -fun execute-test( run : int, base : string, prog : string, envvars : string ) : io either +fun execute-test( run : int, base : string, prog : string, envvars : string ) : io either val timef= "out/time-" ++ base ++ ".txt" val cmd = (if envvars.is-empty then "" else ("env " ++ envvars ++ " ")) ++ (if get-env("SHELL").default("").contains("zsh") @@ -370,13 +370,13 @@ fun execute-test( run : int, base : string, prog : string, envvars : string ) : _ -> val parts = time.replace-all("\n"," ").replace-all("\t"," ").split(" ").filter(fn(p) !p.is-empty ) // println( parts.join(",") ) - match(parts) { + match(parts) Cons(elapsed,Cons(rss,Nil)) -> // linux println("" ++ run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "kb" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)) ) + Right( (parse-float64(elapsed).default(0.0), parse-int(rss).default(0)) ) Cons(elapsed,Cons("real",Cons(_,Cons(_user,Cons(_,Cons(_sys,Cons(rss,_))))))) -> // on macOS println("" ++ run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "b" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) + Right( (parse-float64(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) _ -> Left("bad format") diff --git a/test/bench/readme-icfp22.txt.md b/test/bench/readme-icfp22.txt.md new file mode 100644 index 000000000..77b44c918 --- /dev/null +++ b/test/bench/readme-icfp22.txt.md @@ -0,0 +1,120 @@ +# ICFP Paper Artifact: Reference Counting with Frame Limited Reuse + +Anton Lorenzen and Daan Leijen + +Docker image: daanx/icfp-reuse:1.0 +Digest : sha256:... + +# Getting Started + +We provide a docker image (based on Ubuntu 20.04, about 4GiB) to run the benchmarks: +``` +> docker pull daanx/icfp-reuse:1.0 +> docker run -it daanx/icfp-reuse:1.0 +``` + +We now see the docker prompt as: +``` +> root@a78d3fc4dbf6:/build/koka/test/bench/build# +``` +We will shorten this to `/build/koka/test/bench/build#` in the guide. + +From this prompt, we can test if we can run our benchmarks as: +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=3 --test=rbtree +compile: ../run.kk +loading: std/core +... + +tests : rbtree +languages: koka, kokax, ocaml, haskell, swift, java, cpp + +run: koka/out/bench/kk-rbtree +420000 +1: elapsed: 0.64s, rss: 168156kb + +... + +--- rbtree ---------------- +rbtree, kk, 0.64s ~0.000, 168156kb +rbtree, kkx, 1.54s ~0.000, 168068kb +rbtree, ml, 0.73s ~0.000, 204888kb +rbtree, hs, 1.61s ~0.000, 540516kb +rbtree, sw, 4.63s ~0.000, 269968kb +rbtree, jv, 1.43s ~0.000, 2512520kb +rbtree, cpp, 0.62s ~0.000, 200264kb + +--- normalized rbtree ---------------- +rbtree, kk, 1.00x ~0.000, 1.00x +rbtree, kkx, 2.41x ~0.000, 1.00x +rbtree, ml, 1.14x ~0.000, 1.22x +rbtree, hs, 2.52x ~0.000, 3.21x +rbtree, sw, 7.23x ~0.000, 1.61x +rbtree, jv, 2.23x ~0.000, 14.94x +rbtree, cpp, 0.97x ~0.000, 1.19x +``` + +This runs the `rbtree` benchmark for all systems (koka, kokax, ocaml, haskell, swift, java, cpp), +and eventually provides a summary in absolute runtimes (and rss), and normalized +runtimes (and rss) relative to `koka`. + +Note that the precise results depend quite a bit on the host system -- the above results +are on a 16-core AMD 5950X @ 3.4Ghz. + + +# Step-by-step Guide + +## Run benchmarks + +The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure +the runtime and rss. For the benchmark figures in our paper we used +the following command: +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=10 +``` +to run all benchmarks 10 times for each available language, and use the median +of those runs (and calculate the error interval) + +Running all benchmarks over all systems takes a while (10 to 30min); we can use the `--lang=` and +`--test=` options to run a particular test for a specific language, for example: +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=2 --test=rbtree,binarytrees --lang=kk,ml,cpp +``` + +Available languages are: + +- `kk` : Koka v2.4.1 compiling using gcc 9.4.0. +- `kkx` : Koka v2.4.1 compiling using gcc 9.4.0 but without reuse optimization. +- `ml` : OCaml v4.14.0 using the optimizing compiler (`ocamlopt`) +- `hs` : Haskell GHC 8.6.5 +- `sw` : Swift 5.6.1. +- `jv` : java 17.0.1 2021-10-19 LTS + Java(TM) SE Runtime Environment (build 17.0.1+12-LTS-39) + Java HotSpot(TM) 64-Bit Server VM (build 17.0.1+12-LTS-39, mixed mode, sharing) +- `cpp` : GCC 9.4.0, + +Available tests are described in detail in Section 4 and are: + +- `rbtree` : inserts 42 million items into a red-black tree. +- `rbtree-ck` : a variant of rbtree that keeps a list of every 5th subtree and thus shares many subtrees. +- `deriv` : the symbolic derivative of a large expression. +- `nqueens` : calculates all solutions for the n-queens problem of size 13 into a list, and returns the length of that list. +- `cfold` : constant-folding over a large symbolic expression. +- `binarytrees` : the binarytrees benchmark from the computer benchmark game + + + +## Benchmark Sources + +All the sources are in the `/build/koka/test/bench/` directories. For example: +``` +/build/koka/test/bench/build# ls ../java +CMakeLists.txt binarytrees.java cfold.java deriv.java nqueens.java rbtree.java rbtreeck.java +``` + +## Re-build the Benchmarks + +All tests can be recompiled using: +``` +/build/koka/test/bench/build# cmake --build . +``` diff --git a/test/bench/run.kk b/test/bench/run.kk deleted file mode 100644 index 2955b6c90..000000000 --- a/test/bench/run.kk +++ /dev/null @@ -1,318 +0,0 @@ -import std/num/double -import std/os/file -import std/os/path -import std/os/env -import std/os/dir -import std/os/process -import std/os/flags - -// ---------------------------------------------------- -// Flags -// ---------------------------------------------------- - -val all-test-names = ["rbtree","rbtree-ck","deriv","nqueens","cfold","binarytrees"] -val all-lang-names = [ - ("koka","kk"), - // ("kokax","kkx"), - ("ocaml","ml"), - ("haskell","hs"), - ("swift","sw"), - ("java","jv"), - ("cpp","cpp") -] - -struct iflags { - tests : string = "" - langs : string = "" - chart : bool = False - iter : int = 1 -} - -val flag-descs : list> = { - fun set-tests( f : iflags, s : string ) : iflags { f(tests = s) } - fun set-langs( f : iflags, s : string ) : iflags { f(langs = s) } - fun set-chart( f : iflags, b : bool ) : iflags { f(chart = b) } - fun set-iter( f : iflags, i : string ) : iflags { f(iter = i.parse-int().default(1)) } - [ Flag( "t", ["test"], Req(set-tests,"test"), "comma separated list of tests" ), - Flag( "l", ["lang"], Req(set-langs,"lang"), "comma separated list of languages"), - Flag( "c", ["chart"], Bool(set-chart), "generate latex chart"), - Flag( "i", ["iter"], Req(set-iter,"N"), "use N iterations per test"), - ] -} - -fun flag-usage() { - flag-descs.usage("usage:\n koka run -- [options]\n\noptions:").println - println([ - "\nnotes:", - " tests : " ++ all-test-names.join(", "), - " languages: " ++ all-lang-names.map(snd).join(", ") - ].unlines) -} - -public fun process-flags() : maybe { - val (flags,args,errs) = parse( Iflags(), flag-descs, get-args() ) - if (errs.is-nil && args.is-nil) then { - Just(flags) - } - else { - println( errs.join("\n") ) - flag-usage() - Nothing - } -} - - -// ---------------------------------------------------- -// Test structure -// ---------------------------------------------------- - -struct test { - name: string - lang: string - elapsed: double = 0.0 - elapsed-sdev : double = 0.0 - rss: int = 0 - err: string = "" - norm-elapsed: double = 0.0 - norm-rss: double = 0.0 - norm-elapsed-sdev : double = 0.0 -} - -fun show( test : test ) { - val xs = if (test.err.is-empty) then [ - test.elapsed.core/show(2) ++ "s ~" ++ test.elapsed-sdev.core/show-fixed(3), - test.rss.core/show ++ "kb" - ] else ["error: " ++ test.err] - ([test.name,test.lang.pad-left(3)] ++ xs).join(", ") -} - -fun show-norm( test : test ) { - val xs = if (test.err.is-empty) then [ - test.norm-elapsed.core/show(2) ++ "x ~" ++ test.elapsed-sdev.core/show-fixed(3), - test.norm-rss.core/show(2) ++ "x" - ] else ["error: " ++ test.err] - ([test.name,test.lang.pad-left(3)] ++ xs).join(", ") -} - -// ---------------------------------------------------- -// main -// ---------------------------------------------------- -public fun main() { - match (process-flags()) { - Nothing -> () - Just(flags) { - val test-names = if (flags.tests.is-empty) then all-test-names - else flags.tests.split(",") - val lang-names = if (flags.langs.is-empty) then all-lang-names - else all-lang-names.filter(fn(l){ flags.langs.contains(l.snd) || flags.langs.contains(l.fst) }) - run-tests(test-names,lang-names,flags.chart,flags.iter) - } - } -} - -fun run-tests(test-names : list, lang-names : list<(string,string)>, gen-chart : bool, iterations : int ) { - println("tests : " ++ test-names.join(", ")) - println("languages: " ++ lang-names.map(fst).join(", ")) - - // run tests - val alltests = test-names.flatmap fn(test-name){ - lang-names.map fn(lang){ - run-test( test-name, lang, iterations ) - } - } - - // show test results - test-names.foreach fn(test-name){ - val tests = alltests.filter(fn(t){ t.name == test-name }) - println("\n--- " ++ test-name ++ " ----------------") - println(tests.map(show).join("\n")) - } - - // exit if koka is not part of the tests (since we need it to normalize) - if (!lang-names.map(fst).join(",").contains("koka")) return () - - // normalize tests - val all-ntests = test-names.flatmap fn(test-name){ - val tests = alltests.filter(fn(t){ t.name == test-name }) - - // normalize to koka - val koka = match(tests.filter(fn(t){t.lang == "kk"})) { Cons(t,Nil) -> t } - val ntests = tests.map fn(t) { - val norm = if (koka.elapsed==0.0) then 1.0 else t.elapsed / koka.elapsed - t(norm-elapsed = norm, - norm-rss = if (koka.rss==0) then 1.0 else t.rss.double / koka.rss.double, - norm-elapsed-sdev = norm * t.elapsed-sdev) - } - println("\n--- normalized " ++ test-name ++ " ----------------") - println(ntests.map(show-norm).join("\n")) - ntests - } - - // group by language - val lang-ntests = lang-names.map(fn(l) { - val lang-name = l.snd - (lang-name, all-ntests.filter(fn(t:test){ t.lang == lang-name })) - }) - - // emit latex chart - if (gen-chart) then { - val ymax = 2.0 - val chart-desc = @"6-core AMD 3600XT at 3.8Ghz\\Ubuntu 20.04, Gcc 9.3.0" - val chart-elapsed = chart("time", norm-elapsed, norm-elapsed-sdev, test-names, lang-ntests, ymax, chart-desc) - val chart-rss = chart("rss", norm-rss, fn(t){ 0.0 }, test-names, lang-ntests, ymax, chart-desc) - println("\n") - println(chart-elapsed) - println("\n") - println(chart-rss) - } - () -} - - -// ---------------------------------------------------- -// Latex chart -// ---------------------------------------------------- -fun chart( kind : string, norm : test -> double, norm-sdev : test -> double, test-names : list, lang-ntests : list<(string,list)>, ymax : double = 2.0, desc : string = "" ) : string { - [ tikz-header(test-names,".bench" ++ kind) - , lang-ntests.flatmap(fn(l){ tikz-data(kind, norm, norm-sdev, l, ymax = ymax ) }) - , tikz-picture(kind, test-names, lang-ntests.map(fst), ymax = ymax, desc = desc ) - , tikz-footer(test-names) ].concat.join("\n") -} - - -fun tikz-header( test-names : list, attr : string ) : list { - ["~ Begin Snippet { .benchmark " ++ attr ++ " }", - "\\pgfplotsset{", - " xticklabels = {" ++ test-names.map(fn(n){ "\\strut " ++ n.replace-all("_","\\_")}).join(",") ++ "}", - "}"] -} - -fun tikz-footer( test-names : list ) : list { - [ "~ End Snippet" ] -} - -fun tikz-picture( kind : string, test-names : list, lang-names : list, ymax : double = 2.0, desc : string = "", height:string = "6cm", width:string = "9cm" ) { - val n = test-names.length - 1 - val header = [ - @"", - @"\begin{tikzpicture}\sffamily", - @"\begin{axis}[Chart" ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", - @" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" - ] - val mid = lang-names.map(fn(l){ @" \draw" ++ kind ++ @"{\color" ++ kind ++ l ++ @"{0}}{\data" ++ kind ++ l ++ "};"}) - val footer = [ - if (kind=="time") then @" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" - else "", - // if (desc.is-empty) then "" else @" \chartdesc{" ++ desc.replace-all("\n",@"\\") ++ "};", - @"\end{axis}", - @"\end{tikzpicture}" - ] - (header ++ mid ++ footer) -} - - -fun tikz-data( kind:string, norm : test -> double, norm-sdev : test -> double, lang-ntests : (string,list), ymax : double = 2.0 ) : list { - val (lang,ntests) = lang-ntests - ["", - @"\pgfplotstableread{"] ++ - ntests.map-indexed(fn(i,t){ - if (t.err.is-empty) then { - [i.show, - if (t.norm <= ymax) then t.norm.show-fixed(3) else ymax.show-fixed(3), - if (t.norm > ymax || t.norm-sdev < 0.001) then "0.000" else t.norm-sdev.show-fixed(3), - t.norm.show-fixed(2) // else @"{\outerlabel{" ++ t.norm-elapsed.show(2) ++ "}}" - ].join(" ") - } - else (i.show ++ @" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else @"{\ensuremath{\times}}")) - }) ++ - [@"}\data" ++ kind ++ lang] -} - - -// ---------------------------------------------------- -// Run a single test -// ---------------------------------------------------- - -fun run-test( test-name : string, langt : (string,string), iterations : int ) : io test { - val (lang-long,lang) = langt - val pre = lang.pad-left(3) ++ ", " ++ test-name.pad-left(12) ++ ", " - val dir = if (lang=="kk") then "koka/out/bench" - elif (lang=="kkx") then "koka/outx/bench" - else lang-long - val base = lang ++ "-" ++ test-name - val prog = if (lang-long=="java") - then "java --enable-preview --class-path=" ++ dir ++ " " - ++ (if (test-name=="cfold") then "-Xss128m " else "") - ++ test-name.replace-all("-","") - else dir ++ "/" ++ base - val progpath = if (lang-long=="java") then (dir.path / (test-name.replace-all("-","") ++ ".class")) - else prog.path - println("\nrun: " ++ prog) - - if (!is-file(progpath)) then { - return Test(test-name,lang,err="NA") - } - - val results = list(1,iterations) - .map( fn(i){ execute-test(i,base,prog)} ) - .map( fn(r){ - match(r) { - Left(err) -> Test(test-name,lang,err=err) - Right((elapsed,rss)) -> Test(test-name,lang,elapsed = elapsed, rss = rss) - }}) - match(results.filter(fn(t){ !t.err.is-empty })) { - Cons(t) -> return t - _ -> () - } - - // filter out worst time if more than 2 iterations - val slowest = results.map(fn(t){ t.elapsed }).maximum - val m = results.filter(fn(t){ t.elapsed == slowest }).length - val resultsf = if (m==1 && results.length > 2) - then results.filter(fn(t){ t.elapsed < slowest }) - else results - // take the average of the rest - val n = resultsf.length - val test = resultsf.foldl1( fn(t1,t2){ t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) } ) - - // calc. stddev - val avg = test.elapsed / n.double - val sdev = sqrt( resultsf.map( fn(t){ sqr(t.elapsed - avg) } ).sum / n.double ) - - test( elapsed = avg, elapsed-sdev = sdev, rss = test.rss / n ) -} - -fun test-sum( t1 : test, t2 : test) : test { - t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) -} - -fun execute-test( run : int, base : string, prog : string ) : io either { - val timef= "time-" ++ base ++ ".txt" - val system = run-system-read("uname -s").exn - val cmd = if (system == "Darwin") - then "/usr/bin/time -l 2> " ++ timef ++ " " ++ prog - else "/usr/bin/time -f'%e %M' -o" ++ timef ++ " " ++ prog - val out = run-system-read(cmd).exn - print(out) - val time = read-text-file(timef.path).trim - if (time=="") return Left("no output") - match(time.list) { - Nil -> Left("no output") - Cons(d) | !d.is-digit -> Left(time) // error - _ -> { - val parts = time.replace-all("\n"," ").replace-all("\t"," ").split(" ").filter(fn(p){ !p.is-empty }) - // println( parts.join(",") ) - match(parts) { - Cons(elapsed,Cons(rss,Nil)) { // linux - println(run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "kb" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)) ) - } - Cons(elapsed,Cons("real",Cons(_,Cons(_user,Cons(_,Cons(_sys,Cons(rss,_))))))) { // on macOS - println(run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "b" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) - } - _ -> Left("bad format") - } - } - } -} From f203890b3ea1ccdd9de208ac68b8e464e53734d2 Mon Sep 17 00:00:00 2001 From: Daan Date: Sun, 29 May 2022 12:06:25 -0700 Subject: [PATCH 071/233] update ctail code --- lib/std/core/types-ctail-inline.h | 46 +++++++++++++++++++++---------- samples/handlers/unix.kk | 15 +++++----- test/cgen/ctail9.kk | 4 +-- 3 files changed, 41 insertions(+), 24 deletions(-) diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index 6faa8f5db..441a3213f 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -20,12 +20,27 @@ static inline kk_std_core_types__ctail kk_ctail_unit(kk_context_t* ctx) { return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, ctx); } -// apply a context to a child value -// is_linear is always a constant and set to `true` if the effect is guaranteed linear -static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { + +static inline kk_box_t kk_ctail_apply_linear( kk_std_core_types__ctail acc, kk_box_t child ) { + #if 1 + if (kk_likely(acc.hole != NULL)) { + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); + *(acc.hole) = child; + return acc.res; + } + else { + return child; + } + #else + // this form entices conditional moves from clang (but seems slower in general) + if (acc.hole != NULL) { *acc.hole = child; } + return (acc.hole != NULL ? acc.res : child); + #endif +} + +static inline kk_box_t kk_ctail_apply_nonlinear( kk_std_core_types__ctail acc, kk_box_t child, kk_context_t* ctx ) { // note: written like this for best codegen; be careful when rewriting. - #if !defined(KK_CTAIL_NO_CONTEXT_PATH) - if (acc.hole != NULL && (is_linear || kk_block_is_unique(kk_ptr_unbox(acc.res)))) { // no kk_likely seem slightly better + if (acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res))) { // no kk_likely seem slightly better kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); *(acc.hole) = child; // in-place update the hole with the child return acc.res; @@ -34,18 +49,19 @@ static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t ch return child; } else { - kk_assert_internal(!is_linear && !kk_block_is_unique(kk_ptr_unbox(acc.res))); - return (is_linear ? kk_intf_box(0) : kk_ctail_context_copy_compose(acc.res,child,ctx)); // copy the context path to the hole and compose with the child + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res))); + return kk_ctail_context_copy_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child } +} + +// apply a context to a child value +// is_linear is always a constant and set to `true` if the effect is guaranteed linear +static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { + #if defined(KK_CTAIL_NO_CONTEXT_PATH) + return kk_ctail_apply_linear(acc,child); // compiler generates the right code for the non-linear case #else - if (acc.hole != NULL) { - kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); - *(acc.hole) = child; - return acc.res; - } - else { - return child; - } + if (is_linear) return kk_ctail_apply_linear(acc,child); + else return kk_ctail_apply_nonlinear(acc,child,ctx); #endif } diff --git a/samples/handlers/unix.kk b/samples/handlers/unix.kk index f6707b8f8..7e71cfa30 100644 --- a/samples/handlers/unix.kk +++ b/samples/handlers/unix.kk @@ -1,9 +1,9 @@ -// Based on Daniel Hillerström PhD Thesis, +// Based on Daniel Hillerström's PhD Thesis, // "Foundations for Programming and Implementing Effect Handlers" (chap. 2) // +// which shows how to build an OS API as a composition of (orthogonal) effect handlers. // -// which is based on -// +// The terminology and design is based on: // "The UNIX Time- Sharing System" by Dennis M. Ritchie and Ken Thompson // https://dsf.berkeley.edu/cs262/unix.pdf @@ -67,10 +67,11 @@ effect whoami fun whoami() : string fun env( user : user, action : () -> a ) : e a - with fun whoami() match user - Root -> "root" - Alice -> "alice" - Bob -> "bob" + with fun whoami() + match user + Root -> "root" + Alice -> "alice" + Bob -> "bob" action() fun example3() diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk index 571c7104f..0b2ad9ecd 100644 --- a/test/cgen/ctail9.kk +++ b/test/cgen/ctail9.kk @@ -16,8 +16,8 @@ fun mapx( xs : list, f : a -> e b ) : e list { fun test(n : int) { val xs = list(1,n) val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) - acc + xs.mapxx(fn(x){ x+1 }).sum - //acc + xs.mapx(fn(x){ x+1 }).sum + //acc + xs.mapxx(fn(x){ x+1 }).sum + acc + xs.mapx(fn(x){ x+1 }).sum println("total: " ++ x.show) } From d6c0033e838dac71e5dfd32575ba257884f7d3e6 Mon Sep 17 00:00:00 2001 From: daan Date: Sun, 29 May 2022 20:54:56 -0700 Subject: [PATCH 072/233] add auto unroll for recursive definitions with singleton matches --- koka.cabal | 3 +- src/Common/Name.hs | 3 +- src/Compiler/Compile.hs | 11 +- src/Compiler/Options.hs | 7 +- src/Core/Core.hs | 2 +- src/Core/Inline.hs | 4 +- src/Core/Unroll.hs | 255 ++++++++++++++++++++++++++++++++++++++++ test/cgen/ctail9.kk | 4 +- 8 files changed, 280 insertions(+), 9 deletions(-) create mode 100644 src/Core/Unroll.hs diff --git a/koka.cabal b/koka.cabal index aff24b1ad..e27aaa65b 100644 --- a/koka.cabal +++ b/koka.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.4. -- @@ -75,6 +75,7 @@ executable koka Core.Specialize Core.Uniquefy Core.UnReturn + Core.Unroll Interpreter.Command Interpreter.Interpret Kind.Assumption diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 87f729f14..db78754d2 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -318,7 +318,8 @@ toHiddenUniqueName i "" name toHiddenUniqueName i s name = makeHiddenName (s ++ show i) xname where - xname = if (isAlpha (head (nameId name))) then name else newQualified (nameModule name) ("op") + c = (head (nameId name)) + xname = if (isAlpha c || c=='.' ) then name else newQualified (nameModule name) ("op") diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 24e28946e..569fa88ed 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -66,6 +66,7 @@ import Core.Inlines ( inlinesExtends, extractInlineDefs, inlinesMerge, import Core.Borrowed ( Borrowed ) import Core.Inline ( inlineDefs ) import Core.Specialize +import Core.Unroll ( unrollDefs ) import Static.BindingGroups ( bindingGroups ) import Static.FixityResolve ( fixityResolve, fixitiesNew, fixitiesCompose ) @@ -889,6 +890,12 @@ inferCheck loaded0 flags line coreImports program checkCoreDefs "lifted" -- traceDefGroups "lifted" + -- unroll recursive definitions + when (optUnroll flags > 0) $ + do unrollDefs penv (optUnroll flags) + -- traceDefGroups "unrolled" + + -- specialize specializeDefs <- if (isPrimitiveModule (Core.coreProgName coreProgram)) then return [] else Core.withCoreDefs (\defs -> extractSpecializeDefs (loadedInlines loaded) defs) @@ -905,8 +912,8 @@ inferCheck loaded0 flags line coreImports program -- lifting remaining recursive functions to top level (must be after specialize as that can generate local recursive definitions) liftFunctions penv checkCoreDefs "specialized" - -- traceDefGroups "specialized and lifted" - + -- traceDefGroups "specialized and lifted" + -- simplify once more simplifyDupN coreDefsInlined <- Core.getCoreDefs diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index bae44c658..cd4da77f6 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -176,6 +176,7 @@ data Flags , optInlineMax :: Int , optctail :: Bool , optctailCtxPath :: Bool + , optUnroll :: Int , parcReuse :: Bool , parcSpecialize :: Bool , parcReuseSpec :: Bool @@ -269,6 +270,7 @@ flagsNull 12 -- inlineMax True -- optctail True -- optctailCtxPath + (-1) -- optUnroll True -- parc reuse True -- parc specialize True -- parc reuse specialize @@ -379,6 +381,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , hide $ fflag ["trmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" , hide $ fflag ["trmcctx"] (\b f -> f{optctailCtxPath=b}) "enable trmc context paths" , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" + , hide $ fflag ["unroll"] (\b f -> f{optUnroll=(if b then 1 else 0)}) "enable recursive definition unrolling" -- deprecated , hide $ option [] ["cmake"] (ReqArg cmakeFlag "cmd") "use to invoke cmake" @@ -698,7 +701,9 @@ processOptions flags0 opts then (optInlineMax flags) `div` 3 else (optInlineMax flags), optctailCtxPath = (optctailCtxPath flags && isTargetC (target flags)), - + optUnroll = if (optUnroll flags < 0) + then (if (optimize flags > 0) then 1 else 0) + else optUnroll flags, ccompPath = ccmd, ccomp = cc, ccompDefs = cdefs, diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 320e33ec4..324a0c6a0 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -1210,7 +1210,7 @@ extractSignatures core extractExternals (coreProgExternals core), extractDefs (coreProgDefs core) ] - in -- trace ("extract signatures: " ++ show (map pretty tps)) $ + in -- trace ("extract signatures: " ++ show (map pretty tps)) $ tps where extractExternals = concatMap extractExternal diff --git a/src/Core/Inline.hs b/src/Core/Inline.hs index a8e82b9b0..98d2be9a8 100644 --- a/src/Core/Inline.hs +++ b/src/Core/Inline.hs @@ -7,7 +7,9 @@ ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- --- Inl all local and anonymous functions to top level. No more letrec :-) +-- Inline top-level functions (across modules) +-- Does not inline recursive top-level functions, that is done by specialization +-- (See Core/Specialize). ----------------------------------------------------------------------------- module Core.Inline( inlineDefs diff --git a/src/Core/Unroll.hs b/src/Core/Unroll.hs new file mode 100644 index 000000000..267161313 --- /dev/null +++ b/src/Core/Unroll.hs @@ -0,0 +1,255 @@ +----------------------------------------------------------------------------- +-- Copyright 2022, Microsoft Research, Daan Leijen +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +{---------------------------------------------------------------------------- +Unroll one level of (some) recursive functions: + + fun map( xs : list, f : a -> e b ) : e list + match xs + Cons(x,xx) -> Cons(f(x),xx.map(f)) + Nil -> Nil + +maps to: + + fun mapx( xs : list, f : a -> e b ) : e list + match xs + Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Nil -> Nil + + fun map( xs : list, f : a -> e b ) : e list + match xs + Nil -> Nil + _ -> xs.mapxx(f) +-----------------------------------------------------------------------------} + +module Core.Unroll( unrollDefs ) where + +import qualified Lib.Trace +import Control.Monad +import Control.Applicative +import Data.Maybe( catMaybes ) +import Lib.PPrint +import Common.Failure +import Common.NamePrim ( nameEffectOpen ) +import Common.Name +import Common.Range +import Common.Unique +import Common.Error +import Common.Syntax + +import Kind.Kind +import Type.Type +import Type.Kind +import Type.TypeVar +import Type.Pretty hiding (Env) +import qualified Type.Pretty as Pretty +import Type.Assumption +import Core.Core +import qualified Core.Core as Core +import Core.Pretty +import Core.CoreVar +import Core.Uniquefy + +trace s x = + Lib.Trace.trace s + x + + + +unrollDefs :: Pretty.Env -> Int -> CorePhase () +unrollDefs penv unrollMax + = liftCorePhaseUniq $ \uniq defs -> + runUnroll penv unrollMax uniq $ + do --traceDoc $ \penv -> text "Core.Unrolline.inlineDefs:" <+> ppUnrollines penv inlines + unrollDefGroups defs + + +{-------------------------------------------------------------------------- + transform definition groups +--------------------------------------------------------------------------} +unrollDefGroups :: DefGroups -> Unroll DefGroups +unrollDefGroups dgs + = do xss <- mapM unrollDefGroup dgs + return (concat xss) + +unrollDefGroup :: DefGroup -> Unroll DefGroups +unrollDefGroup (DefRec [def]) + = unrollRecDef def + +unrollDefGroup dg + = return [dg] + +unrollRecDef :: Def -> Unroll [DefGroup] +unrollRecDef def + = withCurrentDef def $ + do -- traceDoc $ \penv -> text "enter def" + dgs <- case defExpr def of + Lam pars eff body + -> unrollBody def [] pars eff body + TypeLam tpars (Lam pars eff body) + -> unrollBody def tpars pars eff body + _ -> return [] + return (if null dgs then [DefRec [def]] else dgs) + +unrollBody :: Def -> [TypeVar] -> [TName] -> Effect -> Expr -> Unroll [DefGroup] +unrollBody def tpars pars eff body + = case body of + Case exprs (branches@((Branch pats _):(_:_))) | all (\x -> costExpr x == 0) exprs -- todo: allow more (total) expressions? + -> case extractNonRecBranches (defTName def) [] branches of + (nonrecbs,recbs) | length nonrecbs > 0 && length recbs > 0 + -> do -- unrollTrace "do unroll" + let dname = defTName def + rname <- uniqueTNameFrom dname + let info = InfoArity (length tpars) (length pars) + sub = [(dname, Var rname info)] + rdef = def{ defName = getName rname, defExpr = (sub |~> defExpr def), defVis = Private } + + rcall = App (makeTypeApp (Var rname info) [TVar tv | tv <- tpars]) [Var v InfoNone | v <- pars] + wild = Branch (map (\_ -> PatWild) pats) [Guard exprTrue rcall] + mkFun b = (if null tpars then id else TypeLam tpars) (Lam pars eff b) + ddef = def{ defExpr = mkFun (Case exprs (nonrecbs ++ [wild])), defInline = InlineAuto, + defDoc = "// unrolling of singleton matches of " ++ show (getName rname) } + unrollTrace ("unroll " ++ show (defName rdef) ++ " to " ++ show (defName ddef)) + return [DefRec [rdef], DefNonRec ddef] + _ -> do -- unrollTrace "no unroll" + return [] + -- todo: allow (small) let bindings? + _ -> return [] + + + +extractNonRecBranches :: TName -> [Branch] -> [Branch] -> ([Branch],[Branch]) +-- stop on end +extractNonRecBranches defname recs [] + = ([],recs) +-- stop also when we cannot push down patterns of recursive branches any further +extractNonRecBranches defname recs (b@(Branch pats guards) : bs) | any (matchCanOverlap b) recs + = ([],recs ++ [b] ++ bs) +-- otherwise +extractNonRecBranches defname recs (b@(Branch pats guards) : bs) + = if not (all singletonPat pats) || -- we only want cheap matches in the unrolling + tnamesMember defname (fv guards) -- and they should be non-recursive + then -- assume it contains a recursive call + -- push down as long the other patterns don't match to maximize non-recursive matches + extractNonRecBranches defname (recs ++ [b]) bs + else -- surely non-recursive, keep going + let (nonrecbs,recbs) = extractNonRecBranches defname recs bs + newb = if null recs then b else dontSkip b + in (newb:nonrecbs,recbs) + +-- is this a singleton (which can be matched without memory access) +singletonPat :: Pattern -> Bool +singletonPat pat + = case pat of + PatVar _ p -> singletonPat p + PatWild -> True + PatLit _ -> True + PatCon{patConPatterns=[]} -> True + _ -> False + +-- Patterns could overlap? (can be conservative, returning True is always ok) +matchCanOverlap (Branch pats1 _) (Branch pats2 _) + = any patCanOverlap (zip pats1 pats2) + where + patCanOverlap pp + = case pp of + (PatWild, _) -> True + (_, PatWild) -> True + (PatVar _ p1,p2) -> patCanOverlap (p1,p2) + (p1,PatVar _ p2) -> patCanOverlap (p1,p2) + (PatLit lit1,PatLit lit2) + -> lit1 == lit2 + (PatCon{patConName=name1}, PatCon{patConName=name2}) + -> name1 == name2 -- TODO: make more precise? + _ -> True + +dontSkip :: Branch -> Branch +dontSkip (Branch pats guards) + = Branch (map noskip pats) guards + where + noskip pat + = case pat of + PatVar name p -> PatVar name (noskip p) + PatCon{patConPatterns=ps} -> pat{ patConSkip = False, patConPatterns = map noskip ps } + _ -> pat + +{-------------------------------------------------------------------------- + Unroll monad +--------------------------------------------------------------------------} +newtype Unroll a = Unroll (Env -> State -> Result a) + +data Env = Env{ currentDef :: [Def], + prettyEnv :: Pretty.Env, + unrollMax :: Int } + +data State = State{ uniq :: !Int } + +data Result a = Ok a State + +runUnroll :: Pretty.Env -> Int -> Int -> Unroll a -> (a,Int) +runUnroll penv unrollMax u (Unroll c) + = case c (Env [] penv unrollMax) (State u) of + Ok x st -> (x,uniq st) + +instance Functor Unroll where + fmap f (Unroll c) = Unroll (\env st -> case c env st of + Ok x st' -> Ok (f x) st') + +instance Applicative Unroll where + pure = return + (<*>) = ap + +instance Monad Unroll where + return x = Unroll (\env st -> Ok x st) + (Unroll c) >>= f = Unroll (\env st -> case c env st of + Ok x st' -> case f x of + Unroll d -> d env st' ) + +instance HasUnique Unroll where + updateUnique f = Unroll (\env st -> Ok (uniq st) st{ uniq = (f (uniq st)) }) + setUnique i = Unroll (\env st -> Ok () st{ uniq = i} ) + +withEnv :: (Env -> Env) -> Unroll a -> Unroll a +withEnv f (Unroll c) + = Unroll (\env st -> c (f env) st) + +--withUnique :: (Int -> (a,Int)) -> Unroll a +--withUnique f +-- = Unroll (\env st -> let (x,u') = f (uniq st) in Ok x (st{ uniq = u'})) + +getEnv :: Unroll Env +getEnv + = Unroll (\env st -> Ok env st) + +updateSt :: (State -> State) -> Unroll State +updateSt f + = Unroll (\env st -> Ok st (f st)) + +withCurrentDef :: Def -> Unroll a -> Unroll a +withCurrentDef def action + = -- trace ("inl def: " ++ show (defName def)) $ + withEnv (\env -> env{currentDef = def:currentDef env}) $ + do -- traceDoc $ (\penv -> text "\ndefinition:" <+> prettyDef penv{Pretty.coreShowDef=True} def) + action + + +traceDoc :: (Pretty.Env -> Doc) -> Unroll () +traceDoc f + = do env <- getEnv + unrollTrace (show (f (prettyEnv env))) + +unrollTrace :: String -> Unroll () +unrollTrace msg + = do env <- getEnv + trace ("inl: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +uniqueTNameFrom :: TName -> Unroll TName +uniqueTNameFrom tname + = do i <- unique + let name = toHiddenUniqueName i "unroll" (getName tname) + return (TName name (typeOf tname)) diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk index 0b2ad9ecd..571c7104f 100644 --- a/test/cgen/ctail9.kk +++ b/test/cgen/ctail9.kk @@ -16,8 +16,8 @@ fun mapx( xs : list, f : a -> e b ) : e list { fun test(n : int) { val xs = list(1,n) val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) - //acc + xs.mapxx(fn(x){ x+1 }).sum - acc + xs.mapx(fn(x){ x+1 }).sum + acc + xs.mapxx(fn(x){ x+1 }).sum + //acc + xs.mapx(fn(x){ x+1 }).sum println("total: " ++ x.show) } From ae3e9110f261509cdba69058d863134b3f9dac0f Mon Sep 17 00:00:00 2001 From: daan Date: Sun, 29 May 2022 21:09:05 -0700 Subject: [PATCH 073/233] update tests for unroll --- src/Core/Unroll.hs | 2 +- test/cgen/specialize/bintree.kk.out | 1 + test/cgen/specialize/branch.kk.out | 5 +++-- test/cgen/specialize/fold1.kk.out | 1 - test/cgen/specialize/fold2.kk.out | 1 + test/cgen/specialize/localdef.kk.out | 2 +- test/cgen/specialize/map-alias.kk.out | 1 + test/cgen/specialize/map.kk.out | 7 +++++-- test/cgen/specialize/map2.kk.out | 7 +++++-- test/cgen/specialize/map3.kk.out | 11 +++++++---- test/cgen/specialize/map4.kk.out | 11 +++++++---- test/cgen/specialize/map5.kk.out | 4 +++- test/cgen/specialize/maptwice.kk.out | 4 +++- test/cgen/specialize/sieve.kk.out | 10 +++++++--- test/cgen/specialize/tree-list.kk.out | 11 +++++++---- test/cgen/specialize/twostep-large2.kk.out | 18 ++++++++++-------- test/cgen/specialize/zipwithacc.kk.out | 7 +++++-- test/parc/parc2.kk.out | 7 ++++++- 18 files changed, 73 insertions(+), 37 deletions(-) diff --git a/src/Core/Unroll.hs b/src/Core/Unroll.hs index 267161313..9957fef39 100644 --- a/src/Core/Unroll.hs +++ b/src/Core/Unroll.hs @@ -56,7 +56,7 @@ import Core.CoreVar import Core.Uniquefy trace s x = - Lib.Trace.trace s + -- Lib.Trace.trace s x diff --git a/test/cgen/specialize/bintree.kk.out b/test/cgen/specialize/bintree.kk.out index 315dc0a39..89f216782 100644 --- a/test/cgen/specialize/bintree.kk.out +++ b/test/cgen/specialize/bintree.kk.out @@ -1,5 +1,6 @@ cgen/specialize/bintree/.lift000-main: (tree350 : tree) -> tree cgen/specialize/bintree/.lift000-main: (xs358 : list) -> list +cgen/specialize/bintree/.lift000-main: (xs363 : list) -> list cgen/specialize/bintree/is-bin: forall (tree : tree) -> bool cgen/specialize/bintree/is-leaf: forall (tree : tree) -> bool cgen/specialize/bintree/main: () -> () diff --git a/test/cgen/specialize/branch.kk.out b/test/cgen/specialize/branch.kk.out index 06efa08df..a2511ce45 100644 --- a/test/cgen/specialize/branch.kk.out +++ b/test/cgen/specialize/branch.kk.out @@ -3,7 +3,8 @@ 2 5 -cgen/specialize/branch/.lift000-main: (xs416 : list) -> console () -cgen/specialize/branch/.lift000-main: forall<_e> (xs423 : list) -> list +cgen/specialize/branch/.lift000-main: (xs418 : list) -> console () +cgen/specialize/branch/.lift000-main: (xs423 : list) -> console () +cgen/specialize/branch/.lift000-main: forall<_e> (xs430 : list) -> list cgen/specialize/branch/main: () -> console () cgen/specialize/branch/map_other: forall (xs : list, f : (a) -> b, g : (a) -> b) -> list \ No newline at end of file diff --git a/test/cgen/specialize/fold1.kk.out b/test/cgen/specialize/fold1.kk.out index 2ae94b10f..759efe184 100644 --- a/test/cgen/specialize/fold1.kk.out +++ b/test/cgen/specialize/fold1.kk.out @@ -5,7 +5,6 @@ add default effect for std/core/exn cgen/specialize/fold1/.hmain: () -> console () cgen/specialize/fold1/.lift000-main: (xs655 : list, z656 : int) -> int -cgen/specialize/fold1/.mlift000-op: (xx660 : list, int) -> int cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index 05f2341cd..2acfb9113 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -2,4 +2,5 @@ cgen/specialize/fold2/.lift000-main: (xs231 : list, z232 : int) -> console int cgen/specialize/fold2/.lift000-main: (xs237 : list, z238 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs243 : list, z244 : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/localdef.kk.out b/test/cgen/specialize/localdef.kk.out index d4b300162..56fd0a225 100644 --- a/test/cgen/specialize/localdef.kk.out +++ b/test/cgen/specialize/localdef.kk.out @@ -2,6 +2,6 @@ cgen/specialize/localdef/.lift000-li: forall (f : (int) -> e a, low : int, high : int, acc : list) -> e list cgen/specialize/localdef/.lift000-main: (low : int, high : int, acc : list) -> console list -cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list +cgen/specialize/localdef/.mlift000-lift212-li: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list cgen/specialize/localdef/li: forall (lo : int, hi : int, f : (int) -> e a) -> e list cgen/specialize/localdef/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/map-alias.kk.out b/test/cgen/specialize/map-alias.kk.out index 9a4e3c1f8..b2be383fe 100644 --- a/test/cgen/specialize/map-alias.kk.out +++ b/test/cgen/specialize/map-alias.kk.out @@ -1,6 +1,7 @@ [2,3,4] cgen/specialize/map-alias/.lift000-main: (xs411 : list) -> console list +cgen/specialize/map-alias/.lift000-main: (xs416 : list) -> console list cgen/specialize/map-alias/main: () -> console () cgen/specialize/map-alias/map2: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map-alias/map3: forall (xs : list, f : (a) -> e b) -> e list \ No newline at end of file diff --git a/test/cgen/specialize/map.kk.out b/test/cgen/specialize/map.kk.out index 8cbc9a659..169f2217c 100644 --- a/test/cgen/specialize/map.kk.out +++ b/test/cgen/specialize/map.kk.out @@ -1,7 +1,10 @@ [2,3,4] -cgen/specialize/map/.lift000-test: (xs223 : list) -> list -cgen/specialize/map/.lift000-main: (xs231 : list) -> list +cgen/specialize/map/.lift000-test: (xs224 : list) -> list +cgen/specialize/map/.lift000-test: (xs229 : list) -> list +cgen/specialize/map/.lift000-main: (xs237 : list) -> list +cgen/specialize/map/.lift000-main: (xs242 : list) -> list +cgen/specialize/map/.unroll123-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/main: () -> console () cgen/specialize/map/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/test: () -> list \ No newline at end of file diff --git a/test/cgen/specialize/map2.kk.out b/test/cgen/specialize/map2.kk.out index 0cf89a488..b3baddc59 100644 --- a/test/cgen/specialize/map2.kk.out +++ b/test/cgen/specialize/map2.kk.out @@ -1,7 +1,10 @@ [3,4,5] -cgen/specialize/map2/.lift000-test: (y : int, xs231 : list) -> list -cgen/specialize/map2/.lift000-main: (xs239 : list) -> list +cgen/specialize/map2/.lift000-test: (y : int, xs232 : list) -> list +cgen/specialize/map2/.lift000-test: (y : int, xs237 : list) -> list +cgen/specialize/map2/.lift000-main: (xs245 : list) -> list +cgen/specialize/map2/.lift000-main: (xs250 : list) -> list +cgen/specialize/map2/.unroll131-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/main: () -> console () cgen/specialize/map2/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/test: (y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map3.kk.out b/test/cgen/specialize/map3.kk.out index b05943fe6..54a83211c 100644 --- a/test/cgen/specialize/map3.kk.out +++ b/test/cgen/specialize/map3.kk.out @@ -1,9 +1,12 @@ [6,7,8,9,10,11,12,13,14,15] -cgen/specialize/map3/.lift000-test: (y : int, xs386 : list) -> list -cgen/specialize/map3/.lift000-main: (xs394 : list) -> list -cgen/specialize/map3/.mlift000-map-poly: forall (a, list) -> e list -cgen/specialize/map3/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map3/.lift000-test: (y : int, xs387 : list) -> list +cgen/specialize/map3/.lift000-test: (y : int, xs392 : list) -> list +cgen/specialize/map3/.lift000-main: (xs400 : list) -> list +cgen/specialize/map3/.lift000-main: (xs405 : list) -> list +cgen/specialize/map3/.mlift000-unroll286-map-poly: forall (a, list) -> e list +cgen/specialize/map3/.mlift000-unroll286-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map3/.unroll286-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/main: () -> console () cgen/specialize/map3/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/test: (xs : list, y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map4.kk.out b/test/cgen/specialize/map4.kk.out index c64d5c2da..85443fc6a 100644 --- a/test/cgen/specialize/map4.kk.out +++ b/test/cgen/specialize/map4.kk.out @@ -1,9 +1,12 @@ 160 -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs321 : list) -> list -cgen/specialize/map4/.lift000-main: (xs329 : list) -> list -cgen/specialize/map4/.mlift000-map-poly: forall (a, list) -> e list -cgen/specialize/map4/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs322 : list) -> list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs327 : list) -> list +cgen/specialize/map4/.lift000-main: (xs335 : list) -> list +cgen/specialize/map4/.lift000-main: (xs340 : list) -> list +cgen/specialize/map4/.mlift000-unroll221-map-poly: forall (a, list) -> e list +cgen/specialize/map4/.mlift000-unroll221-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map4/.unroll221-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/main: () -> console () cgen/specialize/map4/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/test: forall (xs : list, y : int, g : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map5.kk.out b/test/cgen/specialize/map5.kk.out index f3162565a..06571f5e4 100644 --- a/test/cgen/specialize/map5.kk.out +++ b/test/cgen/specialize/map5.kk.out @@ -1,6 +1,8 @@ 115 cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs359 : list) -> list -cgen/specialize/map5/.lift000-main: (xs367 : list) -> list +cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs364 : list) -> list +cgen/specialize/map5/.lift000-main: (xs372 : list) -> list +cgen/specialize/map5/.lift000-main: (xs377 : list) -> list cgen/specialize/map5/main: () -> console () cgen/specialize/map5/test: forall (xs : list, y : int, f : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/maptwice.kk.out b/test/cgen/specialize/maptwice.kk.out index 3741fad75..cb39f3e2e 100644 --- a/test/cgen/specialize/maptwice.kk.out +++ b/test/cgen/specialize/maptwice.kk.out @@ -3,7 +3,9 @@ add default effect for std/core/exn cgen/specialize/maptwice/.hmain: () -> console () cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs618 : list>) -> total list> -cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs626 : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs623 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs631 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs636 : list>) -> total list> cgen/specialize/maptwice/.mlift000-main: (int) -> exn () cgen/specialize/maptwice/.mlift000-main: (list) -> exn () cgen/specialize/maptwice/main: () -> () diff --git a/test/cgen/specialize/sieve.kk.out b/test/cgen/specialize/sieve.kk.out index 37784e300..af8d30959 100644 --- a/test/cgen/specialize/sieve.kk.out +++ b/test/cgen/specialize/sieve.kk.out @@ -23,9 +23,13 @@ 89 97 -cgen/specialize/sieve/.lift000-sieve: (x : int, xs341 : list) -> div list -cgen/specialize/sieve/.lift000-test: (xs351 : list) -> () -cgen/specialize/sieve/.lift000-main: (xs358 : list) -> () +cgen/specialize/sieve/.lift000-unroll241-sieve: (x : int, xs342 : list) -> div list +cgen/specialize/sieve/.lift000-unroll241-sieve: (x : int, xs347 : list) -> div list +cgen/specialize/sieve/.lift000-test: (xs357 : list) -> () +cgen/specialize/sieve/.lift000-test: (xs362 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs369 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs374 : list) -> () +cgen/specialize/sieve/.unroll241-sieve: (xs : list, max : int) -> div list cgen/specialize/sieve/gen-primes: (n : int) -> div list cgen/specialize/sieve/main: () -> () cgen/specialize/sieve/sieve: (xs : list, max : int) -> div list diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index 7d83c252a..eca14d458 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -2,11 +2,14 @@ Tree(2, [Tree(3, []), Tree(4, [])]) cgen/specialize/tree-list/.copy: forall (tree, data : optional, children : optional>>) -> tree cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1149 : list>) -> list> -cgen/specialize/tree-list/.lift000-show: (xs1157 : list>) -> div list +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1154 : list>) -> list> +cgen/specialize/tree-list/.lift000-show: (xs1162 : list>) -> div list +cgen/specialize/tree-list/.lift000-show: (xs1167 : list>) -> div list cgen/specialize/tree-list/.lift000-main: (tree) -> tree -cgen/specialize/tree-list/.lift000-main: (xs1171 : list>) -> list> -cgen/specialize/tree-list/.mlift000-op: forall (tree, list>) -> list> -cgen/specialize/tree-list/.mlift000-op: forall (f : (a) -> b, xx1153 : list>, tree) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1181 : list>) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1186 : list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1194-mapT: forall (tree, list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1194-mapT: forall (f : (a) -> b, xx1158 : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> diff --git a/test/cgen/specialize/twostep-large2.kk.out b/test/cgen/specialize/twostep-large2.kk.out index cca6a5956..aa46ce150 100644 --- a/test/cgen/specialize/twostep-large2.kk.out +++ b/test/cgen/specialize/twostep-large2.kk.out @@ -12,15 +12,17 @@ cgen/specialize/twostep-large2/.lift000-main: (lo531 : int, hi532 : int) -> tota cgen/specialize/twostep-large2/.lift000-main: (lo539 : int, hi540 : int) -> total list> cgen/specialize/twostep-large2/.lift000-main: (lo547 : int, hi548 : int) -> total list cgen/specialize/twostep-large2/.lift000-main: (xs555 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs560 : list) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo571 : int, hi572 : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo579 : int, hi580 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo587 : int, hi588 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs595 : list) -> total list -cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.lift000-main: (lo576 : int, hi577 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo584 : int, hi585 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo592 : int, hi593 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs600 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs605 : list) -> total list +cgen/specialize/twostep-large2/.mlift000-lift612-repeatN: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift612-repeatN: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-lift613-a: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift613-a: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list cgen/specialize/twostep-large2/a: forall (i : int, f : () -> e a) -> e list cgen/specialize/twostep-large2/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large2/large: (f : (int) -> total int) -> total int diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index cbc519c04..34865351c 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,6 +1,9 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i368 : int, acc369 : list, xs370 : list, ys371 : list) -> console list -cgen/specialize/zipwithacc/.mlift000-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list +cgen/specialize/zipwithacc/.lift000-main: (i369 : int, acc370 : list, xs371 : list, ys372 : list) -> console list +cgen/specialize/zipwithacc/.lift000-main: (i377 : int, acc378 : list, xs379 : list, ys380 : list) -> console list +cgen/specialize/zipwithacc/.mlift000-unroll267-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> + e list +cgen/specialize/zipwithacc/.unroll267-zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list cgen/specialize/zipwithacc/main: () -> console () cgen/specialize/zipwithacc/zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list \ No newline at end of file diff --git a/test/parc/parc2.kk.out b/test/parc/parc2.kk.out index 5cf72b7b9..d0ae5e64c 100644 --- a/test/parc/parc2.kk.out +++ b/test/parc/parc2.kk.out @@ -3,5 +3,10 @@ import std/core/types = std/core/types = ""; import std/core = std/core = ""; pub fun test : forall (x : list) -> list = fn(x: list<0>){ - std/core/append((std/core/types/.dup(x)), x); + match (x) { + (std/core/Nil() : (list) ) + -> x; + _ + -> std/core/.unroll17269-append((std/core/types/.dup(x)), x); + }; }; \ No newline at end of file From e0df90b04ddbdaac2bf0e6ee8ab5e85923ad462a Mon Sep 17 00:00:00 2001 From: daan Date: Sun, 29 May 2022 21:35:01 -0700 Subject: [PATCH 074/233] move funtion lifting and unrolling before the inline phase --- src/Compiler/Compile.hs | 21 ++++++++-------- src/Core/Unroll.hs | 14 +++++++---- test/cgen/specialize/branch.kk.out | 6 ++--- test/cgen/specialize/fold2.kk.out | 3 +-- test/cgen/specialize/localdef.kk.out | 4 ++-- test/cgen/specialize/map.kk.out | 8 +++---- test/cgen/specialize/map2.kk.out | 8 +++---- test/cgen/specialize/map3.kk.out | 12 ++++------ test/cgen/specialize/map4.kk.out | 12 ++++------ test/cgen/specialize/sieve.kk.out | 14 +++++------ test/cgen/specialize/tree-list.kk.out | 16 ++++++------- test/cgen/specialize/twostep-large.kk.out | 5 ++-- test/cgen/specialize/twostep-large2.kk.out | 28 +++++++++++----------- test/cgen/specialize/zipwithacc.kk.out | 7 +++--- test/parc/parc2.kk.out | 2 +- 15 files changed, 78 insertions(+), 82 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 569fa88ed..8f7c0db16 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -875,16 +875,6 @@ inferCheck loaded0 flags line coreImports program simplifyNoDup -- traceDefGroups "simplify1" - -- inline: inline local definitions more aggressively (2x) - when (optInlineMax flags > 0) $ - let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded - else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) - in inlineDefs penv (2*(optInlineMax flags)) inlines - -- checkCoreDefs "inlined" - - simplifyDupN - -- traceDefGroups "inlined" - -- lift recursive functions to top-level before specialize (so specializeDefs do not contain local recursive definitions) liftFunctions penv checkCoreDefs "lifted" @@ -894,8 +884,17 @@ inferCheck loaded0 flags line coreImports program when (optUnroll flags > 0) $ do unrollDefs penv (optUnroll flags) -- traceDefGroups "unrolled" - + -- inline: inline local definitions more aggressively (2x) + when (optInlineMax flags > 0) $ + let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded + else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) + in inlineDefs penv (2*(optInlineMax flags)) inlines + -- checkCoreDefs "inlined" + + simplifyDupN + -- traceDefGroups "inlined" + -- specialize specializeDefs <- if (isPrimitiveModule (Core.coreProgName coreProgram)) then return [] else Core.withCoreDefs (\defs -> extractSpecializeDefs (loadedInlines loaded) defs) diff --git a/src/Core/Unroll.hs b/src/Core/Unroll.hs index 9957fef39..cd774a38a 100644 --- a/src/Core/Unroll.hs +++ b/src/Core/Unroll.hs @@ -56,7 +56,7 @@ import Core.CoreVar import Core.Uniquefy trace s x = - -- Lib.Trace.trace s + Lib.Trace.trace s x @@ -112,9 +112,9 @@ unrollBody def tpars pars eff body rcall = App (makeTypeApp (Var rname info) [TVar tv | tv <- tpars]) [Var v InfoNone | v <- pars] wild = Branch (map (\_ -> PatWild) pats) [Guard exprTrue rcall] mkFun b = (if null tpars then id else TypeLam tpars) (Lam pars eff b) - ddef = def{ defExpr = mkFun (Case exprs (nonrecbs ++ [wild])), defInline = InlineAuto, - defDoc = "// unrolling of singleton matches of " ++ show (getName rname) } - unrollTrace ("unroll " ++ show (defName rdef) ++ " to " ++ show (defName ddef)) + ddef = def{ defExpr = mkFun (Case exprs (nonrecbs ++ [wild])), defInline = InlineAlways, + defDoc = "// unrolling of singleton matches of " ++ show (getName rname) ++ "\n" } + verboseDoc $ \penv -> text ("unroll " ++ show (defName ddef) ++ " (to " ++ show (defName rdef) ++ ")") return [DefRec [rdef], DefNonRec ddef] _ -> do -- unrollTrace "no unroll" return [] @@ -253,3 +253,9 @@ uniqueTNameFrom tname = do i <- unique let name = toHiddenUniqueName i "unroll" (getName tname) return (TName name (typeOf tname)) + +verboseDoc :: (Pretty.Env -> Doc) -> Unroll () +verboseDoc f + = do env <- getEnv + when (verbose (prettyEnv env) >= 2) $ + Lib.Trace.trace (show (f (prettyEnv env))) (return ()) \ No newline at end of file diff --git a/test/cgen/specialize/branch.kk.out b/test/cgen/specialize/branch.kk.out index a2511ce45..38f927275 100644 --- a/test/cgen/specialize/branch.kk.out +++ b/test/cgen/specialize/branch.kk.out @@ -3,8 +3,8 @@ 2 5 -cgen/specialize/branch/.lift000-main: (xs418 : list) -> console () -cgen/specialize/branch/.lift000-main: (xs423 : list) -> console () -cgen/specialize/branch/.lift000-main: forall<_e> (xs430 : list) -> list +cgen/specialize/branch/.lift000-main: (xs416 : list) -> console () +cgen/specialize/branch/.lift000-main: (xs421 : list) -> console () +cgen/specialize/branch/.lift000-main: forall<_e> (xs428 : list) -> list cgen/specialize/branch/main: () -> console () cgen/specialize/branch/map_other: forall (xs : list, f : (a) -> b, g : (a) -> b) -> list \ No newline at end of file diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index 2acfb9113..e9165d6a7 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -1,6 +1,5 @@ 55 cgen/specialize/fold2/.lift000-main: (xs231 : list, z232 : int) -> console int -cgen/specialize/fold2/.lift000-main: (xs237 : list, z238 : int) -> console int -cgen/specialize/fold2/.lift000-main: (xs243 : list, z244 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs240 : list, z241 : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/localdef.kk.out b/test/cgen/specialize/localdef.kk.out index 56fd0a225..6cca3b5e6 100644 --- a/test/cgen/specialize/localdef.kk.out +++ b/test/cgen/specialize/localdef.kk.out @@ -1,7 +1,7 @@ ["0","1","2","3","4","5","6","7","8","9","10"] cgen/specialize/localdef/.lift000-li: forall (f : (int) -> e a, low : int, high : int, acc : list) -> e list -cgen/specialize/localdef/.lift000-main: (low : int, high : int, acc : list) -> console list -cgen/specialize/localdef/.mlift000-lift212-li: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list +cgen/specialize/localdef/.lift000-main: (low317 : int, high318 : int, acc319 : list) -> console list +cgen/specialize/localdef/.mlift000-lift207-li: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list cgen/specialize/localdef/li: forall (lo : int, hi : int, f : (int) -> e a) -> e list cgen/specialize/localdef/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/map.kk.out b/test/cgen/specialize/map.kk.out index 169f2217c..95e59bbd5 100644 --- a/test/cgen/specialize/map.kk.out +++ b/test/cgen/specialize/map.kk.out @@ -1,10 +1,8 @@ [2,3,4] -cgen/specialize/map/.lift000-test: (xs224 : list) -> list -cgen/specialize/map/.lift000-test: (xs229 : list) -> list -cgen/specialize/map/.lift000-main: (xs237 : list) -> list -cgen/specialize/map/.lift000-main: (xs242 : list) -> list -cgen/specialize/map/.unroll123-map-int: (xs : list, f : (int) -> int) -> list +cgen/specialize/map/.lift000-test: (xs226 : list) -> list +cgen/specialize/map/.lift000-main: (xs234 : list) -> list +cgen/specialize/map/.unroll117-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/main: () -> console () cgen/specialize/map/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/test: () -> list \ No newline at end of file diff --git a/test/cgen/specialize/map2.kk.out b/test/cgen/specialize/map2.kk.out index b3baddc59..25c72bb68 100644 --- a/test/cgen/specialize/map2.kk.out +++ b/test/cgen/specialize/map2.kk.out @@ -1,10 +1,8 @@ [3,4,5] -cgen/specialize/map2/.lift000-test: (y : int, xs232 : list) -> list -cgen/specialize/map2/.lift000-test: (y : int, xs237 : list) -> list -cgen/specialize/map2/.lift000-main: (xs245 : list) -> list -cgen/specialize/map2/.lift000-main: (xs250 : list) -> list -cgen/specialize/map2/.unroll131-map-int: (xs : list, f : (int) -> int) -> list +cgen/specialize/map2/.lift000-test: (y : int, xs236 : list) -> list +cgen/specialize/map2/.lift000-main: (xs244 : list) -> list +cgen/specialize/map2/.unroll124-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/main: () -> console () cgen/specialize/map2/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/test: (y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map3.kk.out b/test/cgen/specialize/map3.kk.out index 54a83211c..0087d3d19 100644 --- a/test/cgen/specialize/map3.kk.out +++ b/test/cgen/specialize/map3.kk.out @@ -1,12 +1,10 @@ [6,7,8,9,10,11,12,13,14,15] -cgen/specialize/map3/.lift000-test: (y : int, xs387 : list) -> list -cgen/specialize/map3/.lift000-test: (y : int, xs392 : list) -> list -cgen/specialize/map3/.lift000-main: (xs400 : list) -> list -cgen/specialize/map3/.lift000-main: (xs405 : list) -> list -cgen/specialize/map3/.mlift000-unroll286-map-poly: forall (a, list) -> e list -cgen/specialize/map3/.mlift000-unroll286-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list -cgen/specialize/map3/.unroll286-map-poly: forall (xs : list, f : (a) -> e b) -> e list +cgen/specialize/map3/.lift000-test: (y : int, xs391 : list) -> list +cgen/specialize/map3/.lift000-main: (xs399 : list) -> list +cgen/specialize/map3/.mlift000-unroll278-map-poly: forall (a, list) -> e list +cgen/specialize/map3/.mlift000-unroll278-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map3/.unroll278-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/main: () -> console () cgen/specialize/map3/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/test: (xs : list, y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map4.kk.out b/test/cgen/specialize/map4.kk.out index 85443fc6a..fc78d6846 100644 --- a/test/cgen/specialize/map4.kk.out +++ b/test/cgen/specialize/map4.kk.out @@ -1,12 +1,10 @@ 160 -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs322 : list) -> list -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs327 : list) -> list -cgen/specialize/map4/.lift000-main: (xs335 : list) -> list -cgen/specialize/map4/.lift000-main: (xs340 : list) -> list -cgen/specialize/map4/.mlift000-unroll221-map-poly: forall (a, list) -> e list -cgen/specialize/map4/.mlift000-unroll221-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list -cgen/specialize/map4/.unroll221-map-poly: forall (xs : list, f : (a) -> e b) -> e list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs326 : list) -> list +cgen/specialize/map4/.lift000-main: (xs334 : list) -> list +cgen/specialize/map4/.mlift000-unroll211-map-poly: forall (a, list) -> e list +cgen/specialize/map4/.mlift000-unroll211-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map4/.unroll211-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/main: () -> console () cgen/specialize/map4/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/test: forall (xs : list, y : int, g : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/sieve.kk.out b/test/cgen/specialize/sieve.kk.out index af8d30959..39bdc88c0 100644 --- a/test/cgen/specialize/sieve.kk.out +++ b/test/cgen/specialize/sieve.kk.out @@ -23,13 +23,13 @@ 89 97 -cgen/specialize/sieve/.lift000-unroll241-sieve: (x : int, xs342 : list) -> div list -cgen/specialize/sieve/.lift000-unroll241-sieve: (x : int, xs347 : list) -> div list -cgen/specialize/sieve/.lift000-test: (xs357 : list) -> () -cgen/specialize/sieve/.lift000-test: (xs362 : list) -> () -cgen/specialize/sieve/.lift000-main: (xs369 : list) -> () -cgen/specialize/sieve/.lift000-main: (xs374 : list) -> () -cgen/specialize/sieve/.unroll241-sieve: (xs : list, max : int) -> div list +cgen/specialize/sieve/.lift000-unroll238-sieve: (x : int, xs348 : list) -> div list +cgen/specialize/sieve/.lift000-unroll238-sieve: (x : int, xs353 : list) -> div list +cgen/specialize/sieve/.lift000-test: (xs363 : list) -> () +cgen/specialize/sieve/.lift000-test: (xs368 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs375 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs380 : list) -> () +cgen/specialize/sieve/.unroll238-sieve: (xs : list, max : int) -> div list cgen/specialize/sieve/gen-primes: (n : int) -> div list cgen/specialize/sieve/main: () -> () cgen/specialize/sieve/sieve: (xs : list, max : int) -> div list diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index eca14d458..6333ce066 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -1,15 +1,15 @@ Tree(2, [Tree(3, []), Tree(4, [])]) cgen/specialize/tree-list/.copy: forall (tree, data : optional, children : optional>>) -> tree -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1149 : list>) -> list> -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1154 : list>) -> list> -cgen/specialize/tree-list/.lift000-show: (xs1162 : list>) -> div list -cgen/specialize/tree-list/.lift000-show: (xs1167 : list>) -> div list +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1147 : list>) -> list> +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1152 : list>) -> list> +cgen/specialize/tree-list/.lift000-show: (xs1160 : list>) -> div list +cgen/specialize/tree-list/.lift000-show: (xs1165 : list>) -> div list cgen/specialize/tree-list/.lift000-main: (tree) -> tree -cgen/specialize/tree-list/.lift000-main: (xs1181 : list>) -> list> -cgen/specialize/tree-list/.lift000-main: (xs1186 : list>) -> list> -cgen/specialize/tree-list/.mlift000-lift1194-mapT: forall (tree, list>) -> list> -cgen/specialize/tree-list/.mlift000-lift1194-mapT: forall (f : (a) -> b, xx1158 : list>, tree) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1179 : list>) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1184 : list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1192-mapT: forall (tree, list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1192-mapT: forall (f : (a) -> b, xx1156 : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> diff --git a/test/cgen/specialize/twostep-large.kk.out b/test/cgen/specialize/twostep-large.kk.out index eab61791e..9219ea60e 100644 --- a/test/cgen/specialize/twostep-large.kk.out +++ b/test/cgen/specialize/twostep-large.kk.out @@ -1,8 +1,9 @@ 75 75 -cgen/specialize/twostep-large/.lift000-main: (lo257 : int, hi258 : int) -> total list -cgen/specialize/twostep-large/.lift000-main: (lo265 : int, hi266 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: () -> console () +cgen/specialize/twostep-large/.lift000-main: (lo267 : int, hi268 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: (lo275 : int, hi276 : int) -> total list cgen/specialize/twostep-large/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large/large: (f : (int) -> total int) -> total int cgen/specialize/twostep-large/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/twostep-large2.kk.out b/test/cgen/specialize/twostep-large2.kk.out index aa46ce150..e765709b7 100644 --- a/test/cgen/specialize/twostep-large2.kk.out +++ b/test/cgen/specialize/twostep-large2.kk.out @@ -8,21 +8,21 @@ cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo501 : cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo509 : int, hi510 : int) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> console () cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo531 : int, hi532 : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo539 : int, hi540 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo547 : int, hi548 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs555 : list) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs560 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo535 : int, hi536 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo543 : int, hi544 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo551 : int, hi552 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs559 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs564 : list) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo576 : int, hi577 : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo584 : int, hi585 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo592 : int, hi593 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs600 : list) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs605 : list) -> total list -cgen/specialize/twostep-large2/.mlift000-lift612-repeatN: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-lift612-repeatN: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list -cgen/specialize/twostep-large2/.mlift000-lift613-a: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-lift613-a: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.lift000-main: (lo584 : int, hi585 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo592 : int, hi593 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo600 : int, hi601 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs608 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs613 : list) -> total list +cgen/specialize/twostep-large2/.mlift000-lift620-repeatN: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift620-repeatN: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-lift621-a: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift621-a: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list cgen/specialize/twostep-large2/a: forall (i : int, f : () -> e a) -> e list cgen/specialize/twostep-large2/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large2/large: (f : (int) -> total int) -> total int diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index 34865351c..7ec8594e3 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,9 +1,8 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i369 : int, acc370 : list, xs371 : list, ys372 : list) -> console list -cgen/specialize/zipwithacc/.lift000-main: (i377 : int, acc378 : list, xs379 : list, ys380 : list) -> console list -cgen/specialize/zipwithacc/.mlift000-unroll267-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> +cgen/specialize/zipwithacc/.lift000-main: (i375 : int, acc376 : list, xs377 : list, ys378 : list) -> console list +cgen/specialize/zipwithacc/.mlift000-unroll261-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list -cgen/specialize/zipwithacc/.unroll267-zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list +cgen/specialize/zipwithacc/.unroll261-zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list cgen/specialize/zipwithacc/main: () -> console () cgen/specialize/zipwithacc/zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list \ No newline at end of file diff --git a/test/parc/parc2.kk.out b/test/parc/parc2.kk.out index d0ae5e64c..8d037cd36 100644 --- a/test/parc/parc2.kk.out +++ b/test/parc/parc2.kk.out @@ -7,6 +7,6 @@ pub fun test : forall (x : list) -> list (std/core/Nil() : (list) ) -> x; _ - -> std/core/.unroll17269-append((std/core/types/.dup(x)), x); + -> std/core/.unroll17012-append((std/core/types/.dup(x)), x); }; }; \ No newline at end of file From a752d70be6062eef8af268de99d64c6018ef9658 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 30 May 2022 09:07:46 -0700 Subject: [PATCH 075/233] comment --- src/Compiler/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 8f7c0db16..37e7337c9 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -880,7 +880,7 @@ inferCheck loaded0 flags line coreImports program checkCoreDefs "lifted" -- traceDefGroups "lifted" - -- unroll recursive definitions + -- unroll recursive definitions (before inline so generated wrappers can be inlined) when (optUnroll flags > 0) $ do unrollDefs penv (optUnroll flags) -- traceDefGroups "unrolled" From b253d4cc71ca64332ac0fd8c6b0fd72d409b872c Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 1 Jun 2022 11:23:22 -0700 Subject: [PATCH 076/233] add list32 and sum32 --- lib/std/num/int32.kk | 10 +- test/bench/koka/CMakeLists.txt | 8 +- test/bench/koka/binarytrees-fbip.kk | 174 ++++++++++++++++++ test/bench/readme-icfp22.txt.md | 270 ++++++++++++++++++++++++---- 4 files changed, 425 insertions(+), 37 deletions(-) create mode 100644 test/bench/koka/binarytrees-fbip.kk diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 7e5aa67ee..e0ff97e57 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -376,4 +376,12 @@ pub fun for-while32( start: int32, end : int32, action : (int32) -> e maybe ) Nothing -> rep(unsafe-decreasing(i.inc)) Just(x) -> Just(x) else Nothing - rep(start) \ No newline at end of file + rep(start) + +pub fun list32( lo: int32, hi: int32 ) : total list + if lo <= hi + then Cons( lo, list32( unsafe-decreasing(lo.inc), hi ) ) + else Nil + +pub fun sum32( xs : list ) : int32 + xs.foldl( 0.int32, fn(x,y) { x + y } ) diff --git a/test/bench/koka/CMakeLists.txt b/test/bench/koka/CMakeLists.txt index 4f9001543..4adc10b8a 100644 --- a/test/bench/koka/CMakeLists.txt +++ b/test/bench/koka/CMakeLists.txt @@ -2,7 +2,7 @@ set(sources cfold.kk deriv.kk nqueens.kk nqueens-int.kk rbtree-poly.kk rbtree.kk rbtree-int.kk rbtree-ck.kk binarytrees.kk) -find_program(kokadev "koka-v2.3.3-dev") +find_program(kokadev "koka-dev") # stack exec koka -- --target=c -O2 -c $(readlink -f ../cfold.kk) -o cfold find_program(stack "stack" REQUIRED) @@ -26,6 +26,12 @@ foreach (source IN LISTS sources) set(outx_path "${outx_dir}/${namex}") set(outdev_path "${outdev_dir}/${namedev}") + if ("${source}" MATCHES "rbtree*") + set(ccomp "clang") + else() + set(ccomp "gcc") + endfi() + add_custom_command( OUTPUT ${out_path} COMMAND ${koka} --target=c --stack=128M --outputdir=${out_dir} --buildname=${name} -v -O2 -i$ "${source}" diff --git a/test/bench/koka/binarytrees-fbip.kk b/test/bench/koka/binarytrees-fbip.kk new file mode 100644 index 000000000..43f17116c --- /dev/null +++ b/test/bench/koka/binarytrees-fbip.kk @@ -0,0 +1,174 @@ +/* +The Computer Language Benchmarks Game +https://salsa.debian.org/benchmarksgame-team/benchmarksgame/ +*/ +module binarytrees + +import std/os/env +import std/os/task +import std/num/int32 + +type tree + Node( left : tree, right : tree ) + Tip + + +// make a perfectly balanced binary tree of `depth` using FBIP +// to use no extra stack space. +type builder + Top + BuildRight( depth : int, up : builder ) + BuildNode( left : tree, up : builder ) + +// using mutual recursion +fun make-down( depth : int, builder : builder ) : div tree + if depth > 0 + then make-down( depth - 1, BuildRight(depth - 1, builder)) + else make-up( Node(Tip,Tip), builder) + +fun make-up( t : tree, builder : builder ) : div tree + match builder + BuildRight(depth, up) -> make-down( depth, BuildNode(t, up)) + BuildNode(l, up) -> make-up( Node(l, t), up) + Top -> t + +// using a single tail recursive definition +type direction + Down( depth : int ) + Up( t : tree ) + +fun make-fbip( dir : direction, builder : builder) : div tree + match dir + Down(depth) -> if depth > 0 + then make-fbip(Down(depth - 1), BuildRight(depth - 1, builder)) + else make-fbip(Up(Node(Tip,Tip)), builder) + Up(t) -> match builder + BuildRight(depth, up) -> make-fbip(Down(depth), BuildNode(t, up)) + BuildNode(l, up) -> make-fbip(Up(Node(l, t)), up) + Top -> t + +// make a perfectly balanced binary tree of `depth` +fun make-rec( depth : int ) : div tree + if depth > 0 + then Node( make-rec(depth - 1), make-rec(depth - 1) ) + else Node( Tip, Tip ) + +type build + Root + GoRight( depth : int, up : build ) + +fun make-trmc-up( t : tree, b : build ) : div tree + match b + GoRight(depth, Root) -> + Node(t, make-trmc( depth, Root )) + GoRight(depth, up) -> + make-trmc-up( Node(t, make-trmc( depth, Root )), up ) + Root -> t + +fun make-trmc( depth : int, b : build ) : div tree + if depth > 0 + then make-trmc( depth - 1, GoRight(depth - 1, b)) + else make-trmc-up( Node(Tip,Tip), b) + +fun make-trmc-fbip( dir : direction, b : build ) : div tree + match dir + Down(depth) -> + if depth > 0 + then make-trmc-fbip( Down(depth - 1), GoRight(depth - 1, b)) + else make-trmc-fbip( Up(Node(Tip,Tip)), b) + Up(t) -> + match b + GoRight(depth, Root) -> + Node(t, make-trmc-fbip( Down(depth), Root )) + GoRight(depth, up) -> + make-trmc-fbip(Up(Node(t, make-trmc-fbip( Down(depth), Root ))), up ) + Root -> t + +fun make( depth : int ) : div tree + // make-rec(depth) + // make-trmc( depth, Root ) + // make-trmc-fbip( Down( depth), Root ) + // make-down( depth, Top ) + make-fbip(Down(depth), Top) + + + +// FBIP in action: use a visitor to run the checksum tail-recursively +type visit + Done + NodeR( right : tree, v : visit ) + +// tail-recursive checksum +fun checkv( t : tree, v : visit, acc : int ) : div int + match t + Node(l,r) -> checkv( l, NodeR(r,v), acc.inc) + Tip -> match v + NodeR(r,v') -> checkv( r, v', acc) + Done -> acc + +// normal checksum +fun checkr( t : tree ) : div int + match t + Node(l,r) -> l.checkr + r.checkr + 1 + Tip -> 0 + + +fun check( t : tree ) : div int + checkv(t, Done, 0) + //t.checkr + + + +// generate `count` trees of `depth` and return the total checksum +fun sum-count( count : int, depth : int ) : div int + fold-int(count+1,0) fn(i,csum) + // csum + make(depth).check + csum + make(depth).check + + +// parallel sum count: spawn up to `n` sub-tasks to count checksums +fun psum-count( count : int, depth : int ) : pure int + val n = 8 + val partc = count / n + val rest = count % n + val parts = list(1,n, fn(i) task{ sum-count( partc, depth ) }) + sum-count(rest, depth) + parts.await.sum + + +// for depth to max-depth with stride 2, process +// many trees of size depth in parallel and compute the total checksum +fun gen-depth( min-depth : int, max-depth : int ) : pure list<(int,int,promise)> + list(min-depth, max-depth, 2) fn(d) + val count = 2^(max-depth + min-depth - d) // todo: ensure fast 2^n operation + (count, d, task{ psum-count(count, d) }) + //(count, d, task{ sum-count(count, d) } ) // one task per depth + + +// show results +fun show( msg : string, depth : int, check : int ) : console () + println(msg ++ " of depth " ++ depth.show ++ "\t check: " ++ check.show) + + +// main +pub fun main() + // task-set-default-concurrency(8); + val n = get-args().head.default("").parse-int.default(21) + val min-depth = 4 + val max-depth = max(min-depth + 2, n) + + // allocate and free the stretch tree + val stretch-depth = max-depth.inc + show( "stretch tree", stretch-depth, make(stretch-depth).check ) + + // allocate long lived tree + // val long = make(max-depth) + val long = make(max-depth) + + // allocate and free many trees in parallel + val trees = gen-depth( min-depth, max-depth ) + trees.foreach fn((count,depth,csum)) + show( count.show ++ "\t trees", depth, csum.await ) + + // and check if the long lived tree is still good + show( "long lived tree", max-depth, long.check ) + diff --git a/test/bench/readme-icfp22.txt.md b/test/bench/readme-icfp22.txt.md index 77b44c918..978f3e564 100644 --- a/test/bench/readme-icfp22.txt.md +++ b/test/bench/readme-icfp22.txt.md @@ -1,97 +1,137 @@ # ICFP Paper Artifact: Reference Counting with Frame Limited Reuse -Anton Lorenzen and Daan Leijen - -Docker image: daanx/icfp-reuse:1.0 -Digest : sha256:... +Docker image: daanx/icfp22-reuse:1.2 +Digest : sha256:83f5c12b08ed41ac289691dcde0cc7d51d4728cad68f1cf31a1eb3611a5e309a # Getting Started -We provide a docker image (based on Ubuntu 20.04, about 4GiB) to run the benchmarks: +We provide a docker image (based on Ubuntu 20.04, about 5GiB) to run the benchmarks: + ``` -> docker pull daanx/icfp-reuse:1.0 -> docker run -it daanx/icfp-reuse:1.0 +> docker pull daanx/icfp22-reuse:1.2 +> docker run -it daanx/icfp22-reuse:1.2 ``` We now see the docker prompt as: + ``` -> root@a78d3fc4dbf6:/build/koka/test/bench/build# +> root@43108f4c2f0f:/build/koka/test/bench/build# ``` + We will shorten this to `/build/koka/test/bench/build#` in the guide. +This directory also contains this README.md. From this prompt, we can test if we can run our benchmarks as: + ``` /build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=3 --test=rbtree -compile: ../run.kk +compile: ../bench.kk loading: std/core ... tests : rbtree -languages: koka, kokax, ocaml, haskell, swift, java, cpp +languages: koka, kokax, kokaold, ocaml, haskell, swift, java, cpp, kokafbip run: koka/out/bench/kk-rbtree 420000 -1: elapsed: 0.64s, rss: 168156kb +1: elapsed: 0.43s, rss: 135428kb ... --- rbtree ---------------- -rbtree, kk, 0.64s ~0.000, 168156kb -rbtree, kkx, 1.54s ~0.000, 168068kb -rbtree, ml, 0.73s ~0.000, 204888kb -rbtree, hs, 1.61s ~0.000, 540516kb -rbtree, sw, 4.63s ~0.000, 269968kb -rbtree, jv, 1.43s ~0.000, 2512520kb -rbtree, cpp, 0.62s ~0.000, 200264kb +rbtree, kk, 0.41s ~0.010, 135412kb +rbtree, kkx, 0.52s ~0.005, 135426kb +rbtree, kkold, 0.62s ~0.005, 170260kb +rbtree, ml, 0.65s ~0.010, 205834kb +rbtree, hs, 1.48s ~0.015, 540478kb +rbtree, sw, 5.22s ~0.141, 269242kb +rbtree, jv, 1.04s ~0.029, 1576906kb +rbtree, cpp, 0.54s ~0.019, 200170kb +rbtree, kkfbip, 0.38s ~0.017, 135476kb --- normalized rbtree ---------------- -rbtree, kk, 1.00x ~0.000, 1.00x -rbtree, kkx, 2.41x ~0.000, 1.00x -rbtree, ml, 1.14x ~0.000, 1.22x -rbtree, hs, 2.52x ~0.000, 3.21x -rbtree, sw, 7.23x ~0.000, 1.61x -rbtree, jv, 2.23x ~0.000, 14.94x -rbtree, cpp, 0.97x ~0.000, 1.19x +rbtree, kk, 1.00x ~0.010, 1.00x +rbtree, kkx, 1.24x ~0.005, 1.00x +rbtree, kkold, 1.51x ~0.005, 1.26x +rbtree, ml, 1.57x ~0.010, 1.52x +rbtree, hs, 3.55x ~0.015, 3.99x +rbtree, sw, 12.58x ~0.141, 1.99x +rbtree, jv, 2.52x ~0.029, 11.65x +rbtree, cpp, 1.30x ~0.019, 1.48x +rbtree, kkfbip, 0.89x ~0.017, 1.00x ``` -This runs the `rbtree` benchmark for all systems (koka, kokax, ocaml, haskell, swift, java, cpp), +This runs the `rbtree` benchmark for all systems (koka, kokax, kokaold, kokafbip, ocaml, haskell, swift, java, cpp), and eventually provides a summary in absolute runtimes (and rss), and normalized -runtimes (and rss) relative to `koka`. +runtimes (and rss) relative to `koka` (`kk`). Note that the precise results depend quite a bit on the host system -- the above results -are on a 16-core AMD 5950X @ 3.4Ghz. +are on a 16-core AMD 5950X @ 3.4Ghz inside the Docker container. # Step-by-step Guide -## Run benchmarks +## Run All Benchmarks The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure the runtime and rss. For the benchmark figures in our paper we used the following command: + ``` /build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=10 ``` + to run all benchmarks 10 times for each available language, and use the median -of those runs (and calculate the error interval) +of those runs (and calculate the standard error interval). + +The expected results on an AMD5950X are at the bottom of this readme. +These should correspond closely to the results in Section 6 and Figure 8 of the paper. + +Note that results may differ across systems quite a bit (see for example the (non-anonymous) +technical report [1] that contains figures on the M1 in appendix B). +However, to support the conclusions in the paper, only the following should hold: + +1. The results for `koka`, `kokax`, and `kokaold` should be relatively the same as the + expected results for each benchmark. That is, for rbtree for example, `koka` should be fastest, + followed by `kokax` (no TRMC) and then `kokaold` (old reuse algorithm). Also, `kokaold` + should never be much faster than `koka` (within the error margin.). This supports the conclusion + that our new reuse approach is always better. +2. The `kokafbip` versions (for `rbtree`, `rbtree-ck`, and `binarytrees` only) are hopefully as fast + as `koka`. For older systems we have seen it perform less good due to cache effects + but on a modern CPU this should not be the case. (see Section 7 of the paper). +3. The relative results of all other systems (ocaml, haskell, swift, java, cpp) are less + important as those are just there to give a sense of the absolute performance of `koka` + but are not used otherwise. +4. The CPU/Cache/Memory/emulation matters: for example on the AMD5950x/x64 the `rbtree` benchmark + with `kokafbip` is over 30% faster than `cpp`, but on the M1/aarch64 only 7%. [1], or running Docker + emulated on an M1 makes Haskell use over 50x times the memory of koka on rbtree while + normally it should be no more than 5x for rbtree, etc. + + +## Benchmark Descriptions Running all benchmarks over all systems takes a while (10 to 30min); we can use the `--lang=` and `--test=` options to run a particular test for a specific language, for example: + ``` /build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=2 --test=rbtree,binarytrees --lang=kk,ml,cpp ``` Available languages are: -- `kk` : Koka v2.4.1 compiling using gcc 9.4.0. -- `kkx` : Koka v2.4.1 compiling using gcc 9.4.0 but without reuse optimization. -- `ml` : OCaml v4.14.0 using the optimizing compiler (`ocamlopt`) +- `kk` : Koka v2.3.3 compiling using gcc 9.4.0. +- `kkx` : Koka v2.3.3 compiling using gcc 9.4.0 but without TRMC (tail-mod-cons) optimization. +- `kkold` : Koka v2.3.3-old compiling using gcc 9.4.0. This is the compiler exactly like `kk` but + (1) using the old reuse algorithm K and (2) no borrowing, as described in the paper. +- `kkfbip`: Koka v2.3.3 compiling using gcc 9.4.0 but using the FBIP variants of the `rbtree`, + `rbtree-ck`, and `binarytrees` benchmarks as described in the paper (Section 7). +- `ml` : Multicore OCaml v4.14.0 using the optimizing compiler (`ocamlopt`) - `hs` : Haskell GHC 8.6.5 - `sw` : Swift 5.6.1. -- `jv` : java 17.0.1 2021-10-19 LTS +- `jv` : Java 17.0.1 2021-10-19 LTS Java(TM) SE Runtime Environment (build 17.0.1+12-LTS-39) Java HotSpot(TM) 64-Bit Server VM (build 17.0.1+12-LTS-39, mixed mode, sharing) -- `cpp` : GCC 9.4.0, +- `cpp` : GCC 9.4.0 Available tests are described in detail in Section 4 and are: @@ -104,6 +144,13 @@ Available tests are described in detail in Section 4 and are: +The `koka`/`kk` version is using the compiler in `/build/koka-v2.3.3` with the new reuse +algorithm, while `kokaold`/`kkold` is based on the `/build/koka-v2.3.3-old` compiler +that is exactly like `koka` except with the old reuse algorithm and no borrowing. +(This is why we cannot use the more recent (and better) koka v2.4.x versions since we only +carefully maintained the `kokaold` to track `koka` up to the v2.3.3 version). + + ## Benchmark Sources All the sources are in the `/build/koka/test/bench/` directories. For example: @@ -112,9 +159,162 @@ All the sources are in the `/build/koka/test/bench/` directories. For exam CMakeLists.txt binarytrees.java cfold.java deriv.java nqueens.java rbtree.java rbtreeck.java ``` + ## Re-build the Benchmarks All tests can be recompiled using: ``` /build/koka/test/bench/build# cmake --build . ``` + + +## Expected Results in Docker on Windows: + +These were obtained running on Windows inside a Ubuntu 20.04 x86_64 Docker +container on a 16-core AMD 5950X @ 3.4Ghz. + +``` +root@...:/build/koka/test/bench/build# koka -e ../bench.kk -- --iter=10 --norm +... +``` + +``` +--- rbtree ---------------- +rbtree, kk, 0.42s ~0.006, 135468kb +rbtree, kkx, 0.51s ~0.000, 135464kb +rbtree, kkold, 0.61s ~0.003, 170290kb +rbtree, ml, 0.64s ~0.007, 206424kb +rbtree, hs, 1.48s ~0.015, 540504kb +rbtree, sw, 5.25s ~0.095, 269428kb +rbtree, jv, 1.05s ~0.037, 1595502kb +rbtree, cpp, 0.56s ~0.013, 200186kb +rbtree, kkfbip, 0.39s ~0.007, 135468kb + +--- rbtree-ck ---------------- +rbtree-ck, kk, 1.12s ~0.035, 1181986kb +rbtree-ck, kkx, 1.12s ~0.015, 1181980kb +rbtree-ck, kkold, 1.58s ~0.024, 1181930kb +rbtree-ck, ml, 1.94s ~0.039, 1413220kb +rbtree-ck, hs, 14.71s ~0.321, 11591426kb +rbtree-ck, sw, 5.36s ~0.155, 1883714kb +rbtree-ck, jv, 2.16s ~0.010, 2322116kb +rbtree-ck, cpp, error: Command exited with non-zero status 1 +0.05 86368 +rbtree-ck, kkfbip, 1.01s ~0.043, 1182032kb + +--- binarytrees ---------------- +binarytrees, kk, 0.81s ~0.035, 682008kb +binarytrees, kkx, 0.84s ~0.036, 673168kb +binarytrees, kkold, 0.83s ~0.034, 691124kb +binarytrees, ml, 1.62s ~0.034, 175520kb +binarytrees, hs, 7.13s ~0.023, 422944kb +binarytrees, sw, 3.71s ~0.126, 736962kb +binarytrees, jv, 1.90s ~0.042, 2403894kb +binarytrees, cpp, 0.58s ~0.024, 1029256kb +binarytrees, kkfbip, 0.74s ~0.022, 657548kb + +--- deriv ---------------- +deriv, kk, 0.61s ~0.007, 469404kb +deriv, kkx, 0.63s ~0.006, 469376kb +deriv, kkold, 0.74s ~0.004, 469356kb +deriv, ml, 0.81s ~0.005, 433988kb +deriv, hs, 1.40s ~0.009, 499498kb +deriv, sw, 1.62s ~0.016, 930968kb +deriv, jv, 0.57s ~0.013, 818774kb +deriv, cpp, 0.79s ~0.013, 1053314kb +deriv, kkfbip, error: NA + +--- nqueens ---------------- +nqueens, kk, 0.48s ~0.009, 98648kb +nqueens, kkx, 0.49s ~0.003, 98594kb +nqueens, kkold, 0.74s ~0.010, 98592kb +nqueens, ml, 0.79s ~0.003, 181108kb +nqueens, hs, 6.27s ~0.015, 347984kb +nqueens, sw, 2.34s ~0.011, 326944kb +nqueens, jv, 0.77s ~0.008, 317028kb +nqueens, cpp, 0.56s ~0.008, 295512kb +nqueens, kkfbip, error: NA + +--- cfold ---------------- +cfold, kk, 0.09s ~0.003, 143756kb +cfold, kkx, 0.11s ~0.005, 143676kb +cfold, kkold, 0.08s ~0.006, 143716kb +cfold, ml, 0.35s ~0.003, 137096kb +cfold, hs, 0.37s ~0.005, 156426kb +cfold, sw, 0.68s ~0.004, 227808kb +cfold, jv, 0.22s ~0.004, 488270kb +cfold, cpp, 0.28s ~0.004, 421158kb +cfold, kkfbip, error: NA + +--- normalized rbtree ---------------- +rbtree, kk, 1.00x ~0.006, 1.00x +rbtree, kkx, 1.21x ~0.000, 1.00x +rbtree, kkold, 1.45x ~0.003, 1.26x +rbtree, ml, 1.51x ~0.007, 1.52x +rbtree, hs, 3.52x ~0.015, 3.99x +rbtree, sw, 12.49x ~0.095, 1.99x +rbtree, jv, 2.50x ~0.037, 11.78x +rbtree, cpp, 1.33x ~0.013, 1.48x +rbtree, kkfbip, 0.92x ~0.007, 1.00x + +--- normalized rbtree-ck ---------------- +rbtree-ck, kk, 1.00x ~0.035, 1.00x +rbtree-ck, kkx, 1.00x ~0.015, 1.00x +rbtree-ck, kkold, 1.41x ~0.024, 1.00x +rbtree-ck, ml, 1.73x ~0.039, 1.20x +rbtree-ck, hs, 13.14x ~0.321, 9.81x +rbtree-ck, sw, 4.79x ~0.155, 1.59x +rbtree-ck, jv, 1.93x ~0.010, 1.96x +rbtree-ck, cpp, error: Command exited with non-zero status 1 +0.05 86368 +rbtree-ck, kkfbip, 0.90x ~0.043, 1.00x + +--- normalized binarytrees ---------------- +binarytrees, kk, 1.00x ~0.035, 1.00x +binarytrees, kkx, 1.04x ~0.036, 0.99x +binarytrees, kkold, 1.02x ~0.034, 1.01x +binarytrees, ml, 1.99x ~0.034, 0.26x +binarytrees, hs, 8.75x ~0.023, 0.62x +binarytrees, sw, 4.55x ~0.126, 1.08x +binarytrees, jv, 2.34x ~0.042, 3.52x +binarytrees, cpp, 0.72x ~0.024, 1.51x +binarytrees, kkfbip, 0.91x ~0.022, 0.96x + +--- normalized deriv ---------------- +deriv, kk, 1.00x ~0.007, 1.00x +deriv, kkx, 1.03x ~0.006, 1.00x +deriv, kkold, 1.21x ~0.004, 1.00x +deriv, ml, 1.33x ~0.005, 0.92x +deriv, hs, 2.30x ~0.009, 1.06x +deriv, sw, 2.66x ~0.016, 1.98x +deriv, jv, 0.93x ~0.013, 1.74x +deriv, cpp, 1.30x ~0.013, 2.24x +deriv, kkfbip, error: NA + +--- normalized nqueens ---------------- +nqueens, kk, 1.00x ~0.009, 1.00x +nqueens, kkx, 1.01x ~0.003, 1.00x +nqueens, kkold, 1.53x ~0.010, 1.00x +nqueens, ml, 1.63x ~0.003, 1.84x +nqueens, hs, 12.93x ~0.015, 3.53x +nqueens, sw, 4.82x ~0.011, 3.31x +nqueens, jv, 1.59x ~0.008, 3.21x +nqueens, cpp, 1.15x ~0.008, 3.00x +nqueens, kkfbip, error: NA + +--- normalized cfold ---------------- +cfold, kk, 1.00x ~0.003, 1.00x +cfold, kkx, 1.22x ~0.005, 1.00x +cfold, kkold, 0.89x ~0.006, 1.00x +cfold, ml, 3.89x ~0.003, 0.95x +cfold, hs, 4.11x ~0.005, 1.09x +cfold, sw, 7.56x ~0.004, 1.58x +cfold, jv, 2.44x ~0.004, 3.40x +cfold, cpp, 3.11x ~0.004, 2.93x +cfold, kkfbip, error: NA +``` + +## Further References + +[1] Benchmark results on the M1 compiled natively to aarch64 are in appendix B of: + From 91ad2391ec18c4b94384f2d6f797fa6a5cde1258 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 1 Jun 2022 21:02:59 -0700 Subject: [PATCH 077/233] update benchmark --- lib/std/num/int32.kk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index e0ff97e57..eb724605c 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -384,4 +384,4 @@ pub fun list32( lo: int32, hi: int32 ) : total list else Nil pub fun sum32( xs : list ) : int32 - xs.foldl( 0.int32, fn(x,y) { x + y } ) + xs.foldl( 0.int32, fn(x,y) x + y ) From 66cb212417370e45c37971b81af24d1310869151 Mon Sep 17 00:00:00 2001 From: Daan Date: Sun, 5 Jun 2022 08:32:57 -0700 Subject: [PATCH 078/233] initial version of Daniel Hillerstrom's unix example --- samples/handlers/unix.kk | 140 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 135 insertions(+), 5 deletions(-) diff --git a/samples/handlers/unix.kk b/samples/handlers/unix.kk index 7e71cfa30..d840e6e58 100644 --- a/samples/handlers/unix.kk +++ b/samples/handlers/unix.kk @@ -63,15 +63,19 @@ type user Alice Bob +fun show( user : user ) : string + match user + Root -> "root" + Alice -> "alice" + Bob -> "bob" + effect whoami fun whoami() : string + + fun env( user : user, action : () -> a ) : e a - with fun whoami() - match user - Root -> "root" - Alice -> "alice" - Bob -> "bob" + with fun whoami() show(user) action() fun example3() @@ -87,3 +91,129 @@ fun show( (_,s) : ((),string) ) : string fun show( (i,s) : (int,string) ) : string "exit with status " ++ i.show ++ "\n" ++ show(s) + + +// ----------------------------------------- +// Session management +// su: substitute user + +effect su + ctl su( u : user ) : () + +fun session-manager1( initial-user : user, action : () -> a ) : e a + with env(initial-user) + with ctl su( u : user ) + mask + with env(u) + resume(()) + action() + +fun session-manager2( initial-user : user, action : () -> a ) : e a + with fun whoami() show(initial-user) + with ctl su( u : user ) + with override fun whoami() show(u) + resume(()) + action() + +fun session-manager3( initial-user : user, action : () -> a ) : e a + var user := initial-user + with fun whoami() show(user) + with fun su(u) user := u + action() + + +fun example4() + with bio + with status + with session-manager3(Root) + echo("hi ") + echo(whoami()) + su(Alice) + echo(", and hi ") + echo(whoami()) + + +// ----------------------------------------- +// Multitasking +// + +effect fork + ctl fork() : bool // true if this is the parent + + +fun forking( action : () -> a ) : e list + with handler + return(x) [x] + ctl fork() resume(True) ++ resume(False) + action() + + +type pstate + Done(result : a) + Paused(resumption : () -> e pstate ) + +effect interrupt + ctl interrupt() : () + +fun reify-process( action : () -> a ) : e pstate + with raw ctl interrupt() Paused( fn() rcontext.resume(()) ) + Done(action()) + +fun scheduler( pstates : list,a>> ) : list + fun schedule( todos : list,a>>, dones : list ) : list + match todos + Nil -> dones + Cons(Done(x),pp) -> schedule(pp, Cons(x,dones)) + Cons(Paused(p),pp) -> + val ps = forking( p ) + schedule( pp ++ ps, dones ) + schedule(pstates,[]) + +fun timeshare( action : () -> a ) : list + val p = Paused( fn() reify-process(action) ) + scheduler([p]) + + +fun ritchie() : () + echo("UNIX is basically ") + echo("a simple operating system, ") + echo("but ") + echo("you have to be a genius to understand the simplicity.\n") + +fun hamlet() : () + echo("To be, or not to be, ") + echo("that is the question:\n") + echo("Whether 'tis nobler in the mind to suffer\n") + +fun example5() + with return(x:(list,string)) x.snd.println + with bio + with timeshare + with status + with session-manager3(Root) + if fork() then + su(Alice) + ritchie() + else + su(Bob) + hamlet() + + +fun interrupt-write( action : () -> a ) : a + with override fun write(fd,s) { interrupt(); write(fd,s) } + action() + +fun example6() + with return(x:(list,string)) x.snd.println + with bio + with timeshare + with interrupt-write + with status + with session-manager3(Root) + if fork() then + su(Alice) + ritchie() + else + su(Bob) + hamlet() + From 283b155fd5b1ec06baf81fc1cfd7e08168931deb Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 18 Jun 2022 07:41:03 -0700 Subject: [PATCH 079/233] small updates --- lib/std/core/types-ctail-inline.h | 2 +- lib/std/core/types.kk | 2 +- lib/std/num/int32.kk | 11 ++- lib/std/num/int64.kk | 27 +++++++ samples/named-handlers/unify.kk | 114 ++++++++++++++++++++++++++++++ 5 files changed, 152 insertions(+), 4 deletions(-) create mode 100644 samples/named-handlers/unify.kk diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index 441a3213f..e09c1496c 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -32,7 +32,7 @@ static inline kk_box_t kk_ctail_apply_linear( kk_std_core_types__ctail acc, kk_b return child; } #else - // this form entices conditional moves from clang (but seems slower in general) + // this form entices conditional moves (but seems slower in general) if (acc.hole != NULL) { *acc.hole = child; } return (acc.hole != NULL ? acc.res : child); #endif diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 2cf25a1a6..d137e923d 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -186,7 +186,7 @@ pub noinline fun keep( x : a ) : a x // ---------------------------------------------------------------------------- -// Standard functions +// Standard functions // ---------------------------------------------------------------------------- // The identity function returns its argument unchanged diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index eb724605c..da6ef52d6 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -83,7 +83,7 @@ pub inline extern (<) : (int32,int32) -> bool { inline "(#1 < #2)" } pub inline extern (>) : (int32,int32) -> bool { inline "(#1 > #2)" } pub inline extern (+) : (int32,int32) -> int32 - c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB + c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB js inline "((#1 + #2)|0)" pub inline extern (-) : (int32,int32) -> int32 @@ -384,4 +384,11 @@ pub fun list32( lo: int32, hi: int32 ) : total list else Nil pub fun sum32( xs : list ) : int32 - xs.foldl( 0.int32, fn(x,y) x + y ) + // xs.foldl( 0.int32, fn(x,y) x + y ) + sumacc32(xs,0.int32) + +fun sumacc32( xs : list, acc : int32 ) : int32 + match xs + Cons(x,xx) -> sumacc32(xx,acc+x) + Nil -> acc + diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 73e47d706..f31a4999b 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -360,3 +360,30 @@ pub fun fold-int64( start : int64, end : int64, init : a, f : (int64,a) -> e a ) if start >= end then init else val x = f(start,init) fold-int64(unsafe-decreasing(start.inc), end, x, f) + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +// If `action` returns `Just`, the iteration is stopped and the result returned +pub fun for-while64( start: int64, end : int64, action : (int64) -> e maybe ) : e maybe + fun rep( i : int64 ) + if i <= end then + match action(i) + Nothing -> rep(unsafe-decreasing(i.inc)) + Just(x) -> Just(x) + else Nothing + rep(start) + +pub fun list64( lo: int64, hi: int64 ) : total list + if lo <= hi + then Cons( lo, list64( unsafe-decreasing(lo.inc), hi ) ) + else Nil + +pub fun sum64( xs : list ) : int64 + // xs.foldl( 0.int64, fn(x,y) x + y ) + sumacc64(xs,0.int64) + +fun sumacc64( xs : list, acc : int64 ) : int64 + match xs + Cons(x,xx) -> sumacc64(xx,acc+x) + Nil -> acc + diff --git a/samples/named-handlers/unify.kk b/samples/named-handlers/unify.kk new file mode 100644 index 000000000..e76de4a6e --- /dev/null +++ b/samples/named-handlers/unify.kk @@ -0,0 +1,114 @@ +/* Shows the use of named effect handlers under an umbrella effect. + + For more info see the paper: + "First-class named effect handlers", Daan Leijen, Ningning Xie, and Youyou Cong, 2020. +*/ +module unify + +// A unifiable type +type utype + UVar( v : variable ) + UCon( tag : string ) + UApp( t1 : utype, t2 : utype ) + +// A non-unifiable type +type ntype + Con( tag : string ) + App( t1 : ntype, t2 : ntype ) + + +// Umbrella substitution effect +scoped effect subst + ctl fresh() : variable + + +// Unification variables under a substitution +named effect variable in subst // named under umbrella effect `:subst` + fun get() : maybe> // `:(variable) -> ,pure> maybe>` + fun resolve( tp : utype ) : () // `:(variable,utype) -> ,pure> ()` + + +// private (named) handler instance for creating a unification variable +fun with-var(action) + var mtp := Nothing + with v <- named handler + fun get() mtp + fun resolve(tp) + match mtp + Nothing -> + // if occurs(v,tp) then throw("recursive type") + mtp := Just(tp) + Just -> throw("cannot resolve a unification variable more than once") + action(v) + + +// umbrella handler for substitution +fun subst(action : forall () -> ,pure|e> a) : a // required rank-2 signature + with ctl fresh() with-var(resume) + action() + + +// resolve all unification variables to a non-unifiable type +fun resolve-all( tp : utype ) : ,pure> ntype + match tp + UCon(tag) -> Con(tag) + UApp(tp1,tp2) -> App( resolve-all(tp1), resolve-all(tp2) ) + UVar(v) -> + match get(v) + Nothing -> throw( "unresolved variable" ) + Just(tpv) -> resolve-all(tpv) + + +// Unify two types under a substitution handler +fun unify( tp1 : utype, tp2 : utype ) : ,div,exn> utype + match (tp1,tp2) + (UCon(tag1), UCon(tag2)) | tag1 == tag2 -> tp1 + // (UVar(v1), UVar(v2)) | v1 == v2 -> tp1 + (UApp(tp11,tp12),UApp(tp21,tp22)) -> UApp( unify(tp11,tp21), unify(tp12,tp22) ) + (UVar(v1),_) -> match get(v1) + Nothing -> + resolve(v1,tp2) + tp2 + Just(tpv1) -> match tp2 + UVar(v2) -> match get(v2) + Nothing -> + resolve(v2,tpv1) + tpv1 + Just(tpv2) + -> unify(tpv1,tpv2) + _ -> unify(tpv1,tp2) + _ -> throw("cannot unify types") + + +// Helpers to create types +fun inttp() : utype + UCon("int") + +fun list( tp1 : utype ) : utype + UApp( UCon("list"), tp1 ) + +fun to( tp1 : utype, tp2 : utype ) : utype + UApp( UApp( UCon("->"), tp1 ), tp2 ) + +pub fun show( tp : ntype, top : bool = True ) : string + fun parens(s) + if top then s else ("(" ++ s ++ ")" ) + match tp + App(App(Con("->"),t1),t2) -> (t1.show ++ " -> " ++ t2.show).parens + Con(tag) -> tag + App(t1,t2) -> (t1.show ++ " " ++ t2.show(False)).parens + + +// Test unification +pub fun test() + with subst + val a = fresh() + val b = fresh() + val tp1 = to( UVar(a), UVar(a) ) + val tp2 = to( UVar(b), list(inttp()) ) + unify(tp1,tp2).resolve-all + +pub fun main() + val tp = test() + println( "unified type: " ++ tp.show ) + From ff77cc3f05eb4f66eaf34b4310ed1bc37e72fc6a Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Sat, 18 Jun 2022 17:22:27 +0200 Subject: [PATCH 080/233] Do not reuse types with _noreuse suffix --- src/Backend/C/ParcReuse.hs | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 99e3a347e..cd7fbd180 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -22,6 +22,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Char import Data.Maybe (catMaybes, maybeToList) +import Data.List (isSuffixOf) import qualified Data.Set as S import qualified Data.Map as Map import qualified Data.IntMap as M @@ -263,6 +264,8 @@ ruGuard (Guard test expr) -- expects patAdded in depth-order ruTryReuseCon :: TName -> ConRepr -> Expr -> Reuse Expr ruTryReuseCon cname repr conApp | isConAsJust repr -- never try to reuse a Just-like constructor = return conApp +ruTryReuseCon cname repr conApp | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = return conApp -- special case to allow benchmarking the effect of reuse analysis ruTryReuseCon cname repr conApp = do newtypes <- getNewtypes platform <- getPlatform @@ -582,16 +585,18 @@ getRuConSize dataType = do newtypes <- getNewtypes platform <- getPlatform let mdataName = extractDataName dataType - let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName - case mdataInfo of - Just dataInfo - -> do let (dataRepr, _) = getDataRepr dataInfo - let cis = dataInfoConstrs dataInfo - let sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis - case sizes of - (s:ss) | all (==s) ss -> pure $ Just s - _ -> pure Nothing - _ -> pure Nothing + if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName + then return Nothing else do + let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName + case mdataInfo of + Just dataInfo + -> do let (dataRepr, _) = getDataRepr dataInfo + let cis = dataInfoConstrs dataInfo + let sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis + case sizes of + (s:ss) | all (==s) ss -> pure $ Just s + _ -> pure Nothing + _ -> pure Nothing where extractDataName :: Type -> Maybe Name extractDataName tp @@ -603,6 +608,8 @@ getRuConSize dataType -- return the allocated size of a constructor. Return 0 for value types or singletons constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOf _ _ _ repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = (0,0) -- special case to allow benchmarking the effect of reuse analysis constructorSizeOf platform newtypes conName conRepr = let dataRepr = conDataRepr conRepr in case splitFunScheme (typeOf conName) of From f3b50c09df08ac4450e8f24fb7f5974dd4cd1b66 Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 18 Jun 2022 09:06:55 -0700 Subject: [PATCH 081/233] fix bug in effect polymorphic inlining --- src/Compiler/Compile.hs | 8 ++++---- src/Core/Inline.hs | 22 +++++++++++++++++----- 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 37e7337c9..87de94327 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -887,10 +887,10 @@ inferCheck loaded0 flags line coreImports program -- inline: inline local definitions more aggressively (2x) when (optInlineMax flags > 0) $ - let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded - else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) - in inlineDefs penv (2*(optInlineMax flags)) inlines - -- checkCoreDefs "inlined" + do let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded + else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) + inlineDefs penv (2*(optInlineMax flags)) inlines + -- checkCoreDefs "inlined" simplifyDupN -- traceDefGroups "inlined" diff --git a/src/Core/Inline.hs b/src/Core/Inline.hs index 98d2be9a8..9ca16fbc2 100644 --- a/src/Core/Inline.hs +++ b/src/Core/Inline.hs @@ -103,8 +103,8 @@ inlExpr expr -- Applications App (TypeApp f targs) args -> do f0 <- inlExpr f - f' <- inlAppExpr f0 (length targs) (length args) (onlyZeroCost args) args' <- mapM inlExpr args + f' <- inlAppExpr f0 (length targs) (argLength args) (onlyZeroCost args) return (App (TypeApp f' targs) args') App f args @@ -152,9 +152,6 @@ inlExpr expr inlAppExpr :: Expr -> Int -> Int -> Bool -> Inl Expr inlAppExpr expr m n onlyZeroCost = case expr of - App eopen@(TypeApp (Var open info) targs) [f] | getName open == nameEffectOpen - -> do (f') <- inlAppExpr f m n onlyZeroCost - return (App eopen [f']) Var tname varInfo -> do mbInfo <- inlLookup (getName tname) case mbInfo of @@ -170,6 +167,15 @@ inlAppExpr expr m n onlyZeroCost return (expr) Nothing -> do traceDoc $ \penv -> text "not inline candidate:" <+> text (showTName tname) return (expr) + -- handle .open(f) calls + TypeApp f targs | m == 0 -- can happen if it is inside an open as: .open<..>(f<..>) (test: cgen/inline4) + -> do f' <- inlAppExpr f (length targs) n onlyZeroCost + return (TypeApp f' targs) + App eopen@(TypeApp (Var open info) targs) [f] | getName open == nameEffectOpen + -> do -- traceDoc $ \penv -> text "go through open:" <+> text (show (m,n)) + f' <- inlAppExpr f m n onlyZeroCost + return (App eopen [f']) + _ -> return (expr) -- no inlining @@ -270,9 +276,15 @@ inlLookup name traceDoc :: (Pretty.Env -> Doc) -> Inl () traceDoc f = do env <- getEnv - inlTrace (show (f (prettyEnv env))) + inlTrace (show (f (prettyEnv env))) inlTrace :: String -> Inl () inlTrace msg = do env <- getEnv trace ("inl: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +verboseDoc :: (Pretty.Env -> Doc) -> Inl () +verboseDoc f + = do env <- getEnv + when (verbose (prettyEnv env) >= 3) $ + traceDoc f From d69eaf3c0b8ca1f10e5f54ee8eb45957fe4b3783 Mon Sep 17 00:00:00 2001 From: daan Date: Sat, 18 Jun 2022 09:26:15 -0700 Subject: [PATCH 082/233] update tests --- test/cgen/inline4.kk | 39 ++++++++++++++++++++++++++ test/cgen/specialize/fold2.kk.out | 2 +- test/cgen/specialize/zipwithacc.kk.out | 2 +- 3 files changed, 41 insertions(+), 2 deletions(-) create mode 100644 test/cgen/inline4.kk diff --git a/test/cgen/inline4.kk b/test/cgen/inline4.kk new file mode 100644 index 000000000..3df04115b --- /dev/null +++ b/test/cgen/inline4.kk @@ -0,0 +1,39 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun compose(f,g) + fn(x) f(g(x)) + +fun tmap-cps( xs : tree, f : a -> e b, k : tree -> e tree ) : e tree + match xs + Bin(l,x,r) -> l.tmap-cps(f, compose(k, fn(l') { + val y = f(x) + r.tmap-cps(f, fn(r') Bin(l', y, r'))})) + Leaf -> k(Leaf) + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-cps(fn(x) x.inc, id).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index e9165d6a7..dcbcffeb2 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -1,5 +1,5 @@ 55 cgen/specialize/fold2/.lift000-main: (xs231 : list, z232 : int) -> console int -cgen/specialize/fold2/.lift000-main: (xs240 : list, z241 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs243 : list, z244 : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index 7ec8594e3..283c2cf8a 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,6 +1,6 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i375 : int, acc376 : list, xs377 : list, ys378 : list) -> console list +cgen/specialize/zipwithacc/.lift000-main: (i374 : int, acc375 : list, xs376 : list, ys377 : list) -> console list cgen/specialize/zipwithacc/.mlift000-unroll261-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list cgen/specialize/zipwithacc/.unroll261-zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list From 383b246b1bd18d19134e183948f42f10af5921fd Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 11 Jul 2022 09:17:35 -0700 Subject: [PATCH 083/233] update icfp22 artifact description --- test/bench/readme-icfp22.txt.md | 39 +++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 12 deletions(-) diff --git a/test/bench/readme-icfp22.txt.md b/test/bench/readme-icfp22.txt.md index 978f3e564..0f0478dbc 100644 --- a/test/bench/readme-icfp22.txt.md +++ b/test/bench/readme-icfp22.txt.md @@ -1,15 +1,15 @@ # ICFP Paper Artifact: Reference Counting with Frame Limited Reuse -Docker image: daanx/icfp22-reuse:1.2 -Digest : sha256:83f5c12b08ed41ac289691dcde0cc7d51d4728cad68f1cf31a1eb3611a5e309a +Docker image: daanx/icfp22-reuse:1.3 +Digest : sha256:7f6b08c4c47d47c8a532ec48d8f7e76d3ebac8de7be02aea89c685fb090699cf # Getting Started We provide a docker image (based on Ubuntu 20.04, about 5GiB) to run the benchmarks: ``` -> docker pull daanx/icfp22-reuse:1.2 -> docker run -it daanx/icfp22-reuse:1.2 +> docker pull daanx/icfp22-reuse:1.3 +> docker run -it daanx/icfp22-reuse:1.3 ``` We now see the docker prompt as: @@ -83,6 +83,8 @@ the following command: to run all benchmarks 10 times for each available language, and use the median of those runs (and calculate the standard error interval). +The full ICFP'22 paper with supplementary material can be found +in the build directory as `reuse-supplement.pdf`. The expected results on an AMD5950X are at the bottom of this readme. These should correspond closely to the results in Section 6 and Figure 8 of the paper. @@ -119,10 +121,19 @@ Running all benchmarks over all systems takes a while (10 to 30min); we can use Available languages are: -- `kk` : Koka v2.3.3 compiling using gcc 9.4.0. +- `kk` : Koka v2.3.3 compiling using gcc 9.4.0. The sources of this compiler version are in + `/build/koka-v2.3.3` with the compiled binary in the `local/bin/koka` subdirectory. + The new reuse algorithm can be found in the + files `.../src/Backend/C/ParcReuse.hs` and `.../src/Backend/C/Parc.hs` ("Parc" was + the initial name for "Perceus"). - `kkx` : Koka v2.3.3 compiling using gcc 9.4.0 but without TRMC (tail-mod-cons) optimization. - `kkold` : Koka v2.3.3-old compiling using gcc 9.4.0. This is the compiler exactly like `kk` but (1) using the old reuse algorithm K and (2) no borrowing, as described in the paper. + The sources of this compiler are in `/build/koka-v2.3.3-old` with the compiled binary + in the `local/bin/koka` subdirectory. These sources are just as in `v2.3.3` except for the reuse + algorithm which is the "old" algorithm K as described in the paper and no borrowing. + (This is why we cannot use the more recent (and better) koka v2.4.x versions since we only + carefully maintained the `kkold` to track `kk` up to the v2.3.3 version) - `kkfbip`: Koka v2.3.3 compiling using gcc 9.4.0 but using the FBIP variants of the `rbtree`, `rbtree-ck`, and `binarytrees` benchmarks as described in the paper (Section 7). - `ml` : Multicore OCaml v4.14.0 using the optimizing compiler (`ocamlopt`) @@ -144,13 +155,6 @@ Available tests are described in detail in Section 4 and are: -The `koka`/`kk` version is using the compiler in `/build/koka-v2.3.3` with the new reuse -algorithm, while `kokaold`/`kkold` is based on the `/build/koka-v2.3.3-old` compiler -that is exactly like `koka` except with the old reuse algorithm and no borrowing. -(This is why we cannot use the more recent (and better) koka v2.4.x versions since we only -carefully maintained the `kokaold` to track `koka` up to the v2.3.3 version). - - ## Benchmark Sources All the sources are in the `/build/koka/test/bench/` directories. For example: @@ -167,6 +171,17 @@ All tests can be recompiled using: /build/koka/test/bench/build# cmake --build . ``` +The `CMakeList.txt` file includes all language specific `/CMakeLists.txt` files +which each build all the benchmarks for each language in the most optimized way. +The `koka/CMakeLists.txt` compiles each benchmark for each of the four variants +(`kk`, `kkold`, `kkx`, and `kkfbip`). All the binaries go into `build/` +folders. + +The benchmark script `../bench.kk` is a Koka script that runs the various +benchmarks a number of times measuring runtime and memory usage with the +`time` program. It takes all results and calculates the median runtimes, and +can normalize results against Koka. + ## Expected Results in Docker on Windows: From b8a846ac5febf42b37defa4c1c9adc97284f635d Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 11 Jul 2022 11:05:12 -0700 Subject: [PATCH 084/233] update docker files --- util/Dockerfile | 48 ++++++++++++++++++++++------------- util/Dockerfile-minimal | 56 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 86 insertions(+), 18 deletions(-) create mode 100644 util/Dockerfile-minimal diff --git a/util/Dockerfile b/util/Dockerfile index 3eb0eb987..b6798f103 100644 --- a/util/Dockerfile +++ b/util/Dockerfile @@ -1,4 +1,4 @@ -# Created by @Lassik +# Create a docker image with a working Koka compiler (including sources). # # Build: # > docker build -t . @@ -8,29 +8,41 @@ # or # > docker run -v -it # +# To start with a shell prompt: +# > docker run -it bash +# # To publish, use a tag like `kokalang/koka:v2.x.x` # > docker push FROM haskell:8.10.7 AS build -RUN mkdir -p ~/.local/bin \ - && cp /usr/local/bin/stack ~/.local/bin/stack \ - && find /usr/local -type f -delete -RUN apt-get update \ - && apt-get install -y --no-install-recommends cmake \ - && rm -rf /var/lib/apt/lists/* +ENV KOKAVER=dev + +RUN mkdir -p ~/.local/bin +RUN cp /usr/local/bin/stack ~/.local/bin/stack +RUN find /usr/local -type f -delete +RUN apt-get update +RUN apt-get install -y --no-install-recommends ca-certificates +RUN apt-get install -y --no-install-recommends libc-dev build-essential tar cmake +RUN apt-get install -y --no-install-recommends gcc curl + +# Build Koka WORKDIR /build -RUN git clone --recursive https://github.com/koka-lang/koka -b v2.4.0 +RUN git clone --recursive https://github.com/koka-lang/koka -b ${KOKAVER} WORKDIR /build/koka RUN stack build -RUN stack exec koka -- util/bundle -- --postfix=docker -FROM debian:buster -RUN apt-get update \ - && apt-get install -y --no-install-recommends \ - gcc libc-dev make \ - nodejs ca-certificates \ - && rm -rf /var/lib/apt/lists/* -COPY --from=build /build/koka/bundle/koka-docker.tar.gz /usr/local -WORKDIR /usr/local -RUN tar -xzvf koka-docker.tar.gz +# For installing C libraries (pcre2) we use Conan +RUN apt-get install -y --no-install-recommends python3-pip +RUN pip3 install setuptools wheel +RUN pip3 install conan + +# Build Koka install bundle +RUN stack exec koka -- -e util/bundle -- --postfix=docker --prefix=bundle/docker + +# Install +WORKDIR /usr/local +RUN tar -xzvf /build/koka/bundle/koka-docker.tar.gz + +# Entry +WORKDIR /build/koka CMD ["koka"] diff --git a/util/Dockerfile-minimal b/util/Dockerfile-minimal new file mode 100644 index 000000000..066ede248 --- /dev/null +++ b/util/Dockerfile-minimal @@ -0,0 +1,56 @@ +# Create a minimal docker image with a working Koka compiler (binaries only). +# Initial version written by @Lassik +# +# Build: +# > docker build -t -f Dockerfile-minimal . +# +# To Run: +# > docker run -it +# or +# > docker run -v -it +# +# To start with a shell prompt: +# > docker run -it bash +# +# To publish, use a tag like `kokalang/koka:v2.x.x` +# > docker push + + +FROM haskell:8.10.7 AS build +ENV KOKAVER=dev + +RUN mkdir -p ~/.local/bin +RUN cp /usr/local/bin/stack ~/.local/bin/stack +RUN find /usr/local -type f -delete +RUN apt-get update +RUN apt-get install -y --no-install-recommends ca-certificates +RUN apt-get install -y --no-install-recommends libc-dev build-essential tar cmake +RUN apt-get install -y --no-install-recommends gcc curl + +# Build Koka +WORKDIR /build +RUN git clone --recursive https://github.com/koka-lang/koka -b ${KOKAVER} +WORKDIR /build/koka +RUN stack build + +# For installing C libraries (pcre2) we use Conan +RUN apt-get install -y --no-install-recommends python3-pip +RUN pip3 install setuptools wheel +RUN pip3 install conan + +# Create install bundle +RUN stack exec koka -- -e util/bundle -- --postfix=docker --prefix=bundle/docker + +# Create fresh image with just the binaries +FROM debian:buster +RUN apt-get update +RUN apt-get install -y --no-install-recommends gcc libc-dev make +RUN apt-get install -y --no-install-recommends ca-certificates +# apt-get install -y --no-install-recommends nodejs +# RUN rm -rf /var/lib/apt/lists/* +COPY --from=build /build/koka/bundle/koka-docker.tar.gz /usr/local +WORKDIR /usr/local +RUN tar -xzvf koka-docker.tar.gz +WORKDIR /root +RUN mkdir .koka +CMD ["koka"] From 1a0013b38e587cdf8cf4a9c6c75d68ce556b5754 Mon Sep 17 00:00:00 2001 From: daan Date: Thu, 3 Nov 2022 17:45:24 -0700 Subject: [PATCH 085/233] fix kk_likely and kk_unlikely macros to add parenthesis so we can use modern C++ syntax --- kklib/include/kklib.h | 30 +++---- kklib/include/kklib/bits.h | 16 ++-- kklib/include/kklib/box.h | 4 +- kklib/include/kklib/integer.h | 160 ++++++++++++++++----------------- kklib/include/kklib/platform.h | 26 ++++-- kklib/include/kklib/random.h | 4 +- kklib/include/kklib/string.h | 6 +- kklib/src/box.c | 10 +-- kklib/src/integer.c | 16 ++-- kklib/src/random.c | 2 +- kklib/src/refcount.c | 22 ++--- kklib/src/string.c | 16 ++-- kklib/src/vector.c | 4 +- src/Backend/C/FromCore.hs | 6 +- 14 files changed, 166 insertions(+), 156 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 6e928348d..72e5e62e7 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -268,7 +268,7 @@ static inline kk_decl_const bool kk_block_has_tag(const kk_block_t* b, kk_tag_t static inline kk_decl_pure kk_ssize_t kk_block_scan_fsize(const kk_block_t* b) { // number of scan fields const kk_ssize_t sfsize = b->header.scan_fsize; - if (kk_likely(sfsize != KK_SCAN_FSIZE_MAX)) return sfsize; + if kk_likely(sfsize != KK_SCAN_FSIZE_MAX) return sfsize; const kk_block_large_t* bl = (const kk_block_large_t*)b; return (kk_ssize_t)kk_intf_unbox(bl->large_scan_fsize); } @@ -282,11 +282,11 @@ static inline void kk_block_refcount_set(kk_block_t* b, kk_refcount_t rc) { } static inline kk_decl_pure bool kk_block_is_unique(const kk_block_t* b) { - return (kk_likely(kk_block_refcount(b) == 0)); + return kk_likely(kk_block_refcount(b) == 0); } static inline kk_decl_pure bool kk_block_is_thread_shared(const kk_block_t* b) { - return (kk_unlikely(kk_refcount_is_thread_shared(kk_block_refcount(b)))); + return kk_unlikely(kk_refcount_is_thread_shared(kk_block_refcount(b))); } typedef struct kk_block_fields_s { @@ -674,7 +674,7 @@ kk_decl_export kk_reuse_t kk_block_check_drop_reuse(kk_block_t* b, kk_refcount_ static inline kk_block_t* kk_block_dup(kk_block_t* b) { kk_assert_internal(kk_block_is_valid(b)); const kk_refcount_t rc = kk_block_refcount(b); - if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? } else { @@ -702,7 +702,7 @@ static inline void kk_block_drop(kk_block_t* b, kk_context_t* ctx) { static inline void kk_block_decref(kk_block_t* b, kk_context_t* ctx) { kk_assert_internal(kk_block_is_valid(b)); const kk_refcount_t rc = b->header.refcount; - if (kk_unlikely(kk_refcount_is_unique_or_thread_shared(rc))) { // (signed)rc <= 0 + if kk_unlikely(kk_refcount_is_unique_or_thread_shared(rc)) { // (signed)rc <= 0 kk_block_check_decref(b, rc, ctx); // thread-shared, sticky (overflowed), or can be freed? } else { @@ -737,7 +737,7 @@ static inline void kk_block_dropi(kk_block_t* b, kk_context_t* ctx) { } kk_block_free(b,ctx); } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-share or sticky (overflowed) ? } else { @@ -773,7 +773,7 @@ static inline void kk_block_dropn(kk_block_t* b, kk_ssize_t scan_fsize, kk_conte } kk_block_free(b,ctx); } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-shared, sticky (overflowed)? } else { @@ -794,7 +794,7 @@ static inline kk_reuse_t kk_block_dropn_reuse(kk_block_t* b, kk_ssize_t scan_fsi } return b; } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-shared or sticky (overflowed)? return kk_reuse_null; } @@ -959,7 +959,7 @@ static inline void kk_datatype_drop_assert(kk_datatype_t d, kk_tag_t t, kk_conte static inline kk_reuse_t kk_datatype_dropn_reuse(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - if (kk_unlikely(kk_datatype_is_singleton(d))) { + if kk_unlikely(kk_datatype_is_singleton(d)) { return kk_reuse_null; } else { @@ -1139,7 +1139,7 @@ kk_decl_export kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ); static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { if (kk_box_is_ptr(b)) { kk_block_t* bl = kk_ptr_unbox(b); - if (kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST))) { + if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { return kk_unbox_Just_block(bl,ctx); } } @@ -1148,7 +1148,7 @@ static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { } static inline kk_box_t kk_box_Just( kk_box_t b, kk_context_t* ctx ) { - if (kk_likely(!kk_box_is_maybe(b))) { + if kk_likely(!kk_box_is_maybe(b)) { return b; } else { @@ -1246,7 +1246,7 @@ static inline kk_vector_t kk_vector_dup(kk_vector_t v) { } static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { - if (kk_unlikely(length<=0)) { + if kk_unlikely(length<=0) { if (buf != NULL) *buf = NULL; return kk_vector_empty(); } @@ -1272,7 +1272,7 @@ static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_co static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len) { kk_vector_large_t v = kk_vector_as_large_borrow(vd); - if (kk_unlikely(v==NULL)) { + if kk_unlikely(v==NULL) { if (len != NULL) *len = 0; return NULL; } @@ -1353,7 +1353,7 @@ static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { } static inline kk_box_t kk_ref_get(kk_ref_t r, kk_context_t* ctx) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); kk_box_dup(b); @@ -1367,7 +1367,7 @@ static inline kk_box_t kk_ref_get(kk_ref_t r, kk_context_t* ctx) { } static inline kk_box_t kk_ref_swap_borrow(kk_ref_t r, kk_box_t value) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); kk_atomic_store_relaxed(&r->value, value.box); diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index 54851db13..70d0e649b 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -141,14 +141,14 @@ extern bool kk_has_tzcnt; static inline uint8_t kk_bits_clz32(uint32_t x) { #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_lzcnt)) return (uint8_t)__lzcnt(x); + if kk_likely(kk_has_lzcnt) return (uint8_t)__lzcnt(x); #endif unsigned long idx; return (_BitScanReverse(&idx, x) ? 31 - (uint8_t)idx : 32); } static inline uint8_t kk_bits_ctz32(uint32_t x) { #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_tzcnt)) return (uint8_t)_tzcnt_u32(x); + if kk_likely(kk_has_tzcnt) return (uint8_t)_tzcnt_u32(x); #endif unsigned long idx; return (_BitScanForward(&idx, x) ? (uint8_t)idx : 32); @@ -157,14 +157,14 @@ static inline uint8_t kk_bits_ctz32(uint32_t x) { #define HAS_BITS_CLZ64 static inline uint8_t kk_bits_clz64(uint64_t x) { #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_lzcnt)) return (uint8_t)__lzcnt64(x); + if kk_likely(kk_has_lzcnt) return (uint8_t)__lzcnt64(x); #endif unsigned long idx; return (_BitScanReverse64(&idx, x) ? 63 - (uint8_t)idx : 64); } static inline uint8_t kk_bits_ctz64(uint64_t x) { #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_tzcnt)) return (uint8_t)_tzcnt_u64(x); + if kk_likely(kk_has_tzcnt) return (uint8_t)_tzcnt_u64(x); #endif unsigned long idx; return (_BitScanForward64(&idx, x) ? (uint8_t)idx : 64); @@ -526,12 +526,12 @@ static inline uint8_t kk_bits_digits(kk_uintx_t x) { ------------------------------------------------------------------ */ static inline int32_t kk_bits_midpoint32( int32_t x, int32_t y ) { - if (kk_likely(x <= y)) return x + (int32_t)(((uint32_t)y - (uint32_t)x)/2); + if kk_likely(x <= y) return x + (int32_t)(((uint32_t)y - (uint32_t)x)/2); else return x - (int32_t)(((uint32_t)x - (uint32_t)y)/2); } static inline int64_t kk_bits_midpoint64(int64_t x, int64_t y) { - if (kk_likely(x <= y)) return x + (int64_t)(((uint64_t)y - (uint64_t)x)/2); + if kk_likely(x <= y) return x + (int64_t)(((uint64_t)y - (uint64_t)x)/2); else return x - (int64_t)(((uint64_t)x - (uint64_t)y)/2); } @@ -540,12 +540,12 @@ static inline kk_intx_t kk_bits_midpoint(kk_intx_t x, kk_intx_t y) { } static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { - if (kk_likely(x <= y)) return (x + (y-x)/2); + if kk_likely(x <= y) return (x + (y-x)/2); else return (x - (x-y)/2); } static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { - if (kk_likely(x <= y)) return (x + (y-x)/2); + if kk_likely(x <= y) return (x + (y-x)/2); else return (x - (x-y)/2); } diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index ca83e36a3..141dc487c 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -331,7 +331,7 @@ typedef struct kk_boxed_value_s { #define kk_valuetype_unbox_(tp,p,x,box,ctx) \ do { \ - if (kk_unlikely(kk_box_is_any(box))) { \ + if kk_unlikely(kk_box_is_any(box)) { \ p = NULL; \ const size_t kk__max_scan_fsize = sizeof(tp)/sizeof(kk_box_t); \ kk_box_t* _fields = (kk_box_t*)(&x); \ @@ -399,7 +399,7 @@ kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx // if we can guarantee for those function addresses to be always aligned we // can perhaps optimize this further (without needing a check)? static inline kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b) { // never drop; only used from function call - if (kk_likely(kk_box_is_value(b))) { + if kk_likely(kk_box_is_value(b)) { return (kk_cfun_ptr_t)(kk_uintf_unbox(b)); } else { diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 28989965e..8f7f207ca 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -99,8 +99,8 @@ if we added two small integers, (where bit 1 must be set after an addition): intptr_t kk_integer_add(intptr_t x, intptr_t y) { intptr_t z = x + y; - if (kk_likely((z|2) == (int32_t)z)) return (z^3); - else return kk_integer_add_generic(x,y); + if kk_likely((z|2) == (int32_t)z) return (z^3); + else return kk_integer_add_generic(x,y); } Now we have just one test that test both for overflow, as well as for the @@ -316,17 +316,17 @@ static inline bool kk_integer_small_eq(kk_integer_t x, kk_integer_t y) { #define kk_integer_min_one (kk_integer_from_small(-1)) static inline bool kk_integer_is_zero_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_zero)); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_zero)); return false; } static inline bool kk_integer_is_one_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_one)); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_one)); return false; } static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_min_one)); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_min_one)); return false; } @@ -371,12 +371,12 @@ static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { } #else static inline kk_integer_t kk_integer_dup(kk_integer_t i) { - if (kk_unlikely(kk_is_bigint(i))) { kk_block_dup(_kk_integer_ptr(i)); } + if kk_unlikely(kk_is_bigint(i)) { kk_block_dup(_kk_integer_ptr(i)); } return i; } static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { - if (kk_unlikely(kk_is_bigint(i))) { kk_block_drop(_kk_integer_ptr(i), ctx); } + if kk_unlikely(kk_is_bigint(i)) { kk_block_drop(_kk_integer_ptr(i), ctx); } } #endif @@ -435,7 +435,7 @@ static inline kk_integer_t kk_integer_from_uint8(uint8_t u, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else - return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); + return kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx); #endif } @@ -444,7 +444,7 @@ static inline kk_integer_t kk_integer_from_int8(int8_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } @@ -453,7 +453,7 @@ static inline kk_integer_t kk_integer_from_int16(int16_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } @@ -462,7 +462,7 @@ static inline kk_integer_t kk_integer_from_int32(int32_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } @@ -471,20 +471,20 @@ static inline kk_integer_t kk_integer_from_uint32(uint32_t u, kk_context_t* ctx) kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else - return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); + return kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx); #endif } static inline kk_integer_t kk_integer_from_int64(int64_t i, kk_context_t* ctx) { - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big64(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big64(i, ctx); } static inline kk_integer_t kk_integer_from_uint64(uint64_t i, kk_context_t* ctx) { - return (kk_likely(i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_bigu64(i, ctx)); + return kk_likely(i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_bigu64(i, ctx); } static inline kk_integer_t kk_integer_from_int(kk_intx_t i, kk_context_t* ctx) { - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big(i, ctx); } @@ -569,7 +569,7 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; - if (kk_unlikely(__builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z) || (z&2)==0)) { + if kk_unlikely(__builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z) || (z&2)==0) { return kk_integer_add_generic(x,y,ctx); } kk_assert_internal((z&3) == 2); @@ -579,7 +579,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z; - if (kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i,2), &z))) { + if kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i,2), &z)) { return kk_integer_add_generic(x,kk_integer_from_small(i),ctx); } kk_assert_internal((z&3) == 1); @@ -588,7 +588,7 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; - if (kk_unlikely(__builtin_sub_overflow(_kk_integer_value(x)^3, _kk_integer_value(y), &z) || (z&2)!=0)) { + if kk_unlikely(__builtin_sub_overflow(_kk_integer_value(x)^3, _kk_integer_value(y), &z) || (z&2)!=0) { return kk_integer_sub_generic(x,y,ctx); } kk_assert_internal((z&3) == 1); @@ -600,7 +600,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t i = kk_sar(_kk_integer_value(x), 1); kk_intf_t j = kk_sar(_kk_integer_value(y), 1); kk_intf_t z; - if (kk_unlikely(__builtin_mul_overflow(i, j, &z))) { + if kk_unlikely(__builtin_mul_overflow(i, j, &z)) { return kk_integer_mul_generic(x, y, ctx); } kk_assert_internal((z&3)==0); @@ -611,7 +611,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; - if (kk_unlikely(!kk_are_smallints(x, y) || __builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z))) { + if kk_unlikely(!kk_are_smallints(x, y) || __builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z)) { return kk_integer_add_generic(x, y, ctx); } kk_assert_internal((z & 3) == 2); @@ -621,7 +621,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z; - if (kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i, 2), &z))) { + if kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i, 2), &z)) { return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); } kk_assert_internal((z & 3) == 1); @@ -630,7 +630,7 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; - if (kk_unlikely(!kk_are_smallints(x, y) || __builtin_sub_overflow(_kk_integer_value(x) ^ 3, _kk_integer_value(y), &z))) { + if kk_unlikely(!kk_are_smallints(x, y) || __builtin_sub_overflow(_kk_integer_value(x) ^ 3, _kk_integer_value(y), &z)) { return kk_integer_sub_generic(x, y, ctx); } kk_assert_internal((z & 3) == 1); @@ -642,7 +642,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t i = kk_sar(_kk_integer_value(x), 1); kk_intf_t j = kk_sar(_kk_integer_value(y), 1); kk_intf_t z; - if (kk_unlikely(__builtin_mul_overflow(i, j, &z))) { + if kk_unlikely(__builtin_mul_overflow(i, j, &z)) { return kk_integer_mul_generic(x, y, ctx); } kk_assert_internal((z & 3) == 0); @@ -659,26 +659,26 @@ static inline bool kk_not_in_small_range( kk_intf_t i ) { static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_add_generic(x, y, ctx); + if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_add_generic(x, y, ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + i; - if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); return _kk_new_integer(z); } static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { #if 1 kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); - if (kk_unlikely(!kk_is_smallint(y) || kk_not_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); - //if (kk_unlikely(!kk_is_smallint(y))) return kk_integer_add_generic(x,y,ctx); + if kk_unlikely(!kk_is_smallint(y) || kk_not_in_small_range(z)) return kk_integer_sub_generic(x, y, ctx); + //if kk_unlikely(!kk_is_smallint(y)) return kk_integer_add_generic(x,y,ctx); return _kk_new_integer(z); #else const kk_intf_t i = _kk_integer_value(x); const kk_intf_t z = i + i - _kk_integer_value(y); - if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_sub_generic(x, y, ctx); + if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_sub_generic(x, y, ctx); return _kk_new_integer(z - i); #endif } @@ -686,8 +686,8 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); kk_intf_t z = _kk_integer_value(x) * _kk_integer_value(y); - // if (kk_unlikely(!kk_are_smallints(x,y))) return kk_integer_mul_generic(x, y, ctx); - if (kk_unlikely(kk_not_in_small_range(z))) return kk_integer_mul_generic(x, y, ctx); + // if kk_unlikely(!kk_are_smallints(x,y)) return kk_integer_mul_generic(x, y, ctx); + if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_mul_generic(x, y, ctx); return _kk_new_integer(z); } @@ -704,9 +704,9 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z|2) == (kk_smallint_t)z)) // set bit 1 and compare sign extension + if kk_likely((z|2) == (kk_smallint_t)z) // set bit 1 and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z|2))) + if kk_likely(z == ((kk_smallint_t)z|2)) #endif { kk_assert_internal((z&3) == 2); @@ -719,9 +719,9 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z|1) == (kk_smallint_t)z)) + if kk_likely((z|1) == (kk_smallint_t)z) #else - if (kk_likely(z == ((kk_smallint_t)z|1))) + if kk_likely(z == ((kk_smallint_t)z|1)) #endif { kk_assert_internal((z&3) == 1); @@ -734,9 +734,9 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = (_kk_integer_value(x)^3) - _kk_integer_value(y); #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z&~2) == (kk_smallint_t)z)) // clear bit 1 and compare sign extension + if kk_likely((z&~2) == (kk_smallint_t)z) // clear bit 1 and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z&~2))) + if kk_likely(z == ((kk_smallint_t)z&~2)) #endif { kk_assert_internal((z&3) == 1); @@ -751,9 +751,9 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z&~3) == (kk_smallint_t)z)) // clear lower 2 bits and compare sign extension + if kk_likely((z&~3) == (kk_smallint_t)z) // clear lower 2 bits and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z&~3))) + if kk_likely(z == ((kk_smallint_t)z&~3)) #endif { kk_assert_internal((z&3) == 0); @@ -766,9 +766,9 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z&~3) == (kk_smallint_t)z)) + if kk_likely((z&~3) == (kk_smallint_t)z) #else - if (kk_likely(z == ((kk_smallint_t)z&~3))) + if kk_likely(z == ((kk_smallint_t)z&~3)) #endif { kk_assert_internal((z&3) == 0); @@ -781,9 +781,9 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) - (_kk_integer_value(y)^3) + 3; #ifndef KK_INT_SOFA_RIGHT_BIAS - if (kk_likely((z&~3) == (kk_smallint_t)z)) // clear lower 2 bits and compare sign extension + if kk_likely((z&~3) == (kk_smallint_t)z) // clear lower 2 bits and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z&~3))) + if kk_likely(z == ((kk_smallint_t)z&~3)) #endif { kk_assert_internal((z&3) == 0); @@ -799,7 +799,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t i = kk_sar(_kk_integer_value(x), 1); kk_intf_t j = kk_sar(_kk_integer_value(y), 1); kk_intf_t z = i*j; - if (kk_likely(z == (kk_smallint_t)(z))) { + if kk_likely(z == (kk_smallint_t)(z)) { kk_assert_internal((z&3) == 0); return _kk_new_integer(z|KK_INT_TAG); } @@ -811,7 +811,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #endif static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return kk_integer_mul_small(x, y, ctx); + if kk_likely(kk_are_smallints(x, y)) return kk_integer_mul_small(x, y, ctx); return kk_integer_mul_generic(x, y, ctx); } @@ -915,39 +915,39 @@ static inline bool kk_are_small_div_ints(kk_integer_t x, kk_integer_t y) { } static inline kk_integer_t kk_integer_cdiv(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cdiv_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cdiv_small(x, y); return kk_integer_cdiv_generic(x, y, ctx); } static inline kk_integer_t kk_integer_cmod(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cmod_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cmod_small(x, y); return kk_integer_cmod_generic(x, y, ctx); } static inline kk_integer_t kk_integer_cdiv_cmod(kk_integer_t x, kk_integer_t y, kk_integer_t* mod, kk_context_t* ctx) { kk_assert_internal(mod!=NULL); - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cdiv_cmod_small(x, y, mod); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cdiv_cmod_small(x, y, mod); return kk_integer_cdiv_cmod_generic(x, y, mod, ctx); } static inline kk_integer_t kk_integer_div(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_div_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_div_small(x, y); return kk_integer_div_generic(x, y, ctx); } static inline kk_integer_t kk_integer_mod(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_mod_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_mod_small(x, y); return kk_integer_mod_generic(x, y, ctx); } static inline kk_integer_t kk_integer_div_mod(kk_integer_t x, kk_integer_t y, kk_integer_t* mod, kk_context_t* ctx) { kk_assert_internal(mod!=NULL); - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_div_mod_small(x, y, mod); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_div_mod_small(x, y, mod); return kk_integer_div_mod_generic(x, y, mod, ctx); } static inline kk_integer_t kk_integer_sqr(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return kk_integer_mul_small(x, x, ctx); + if kk_likely(kk_is_smallint(x)) return kk_integer_mul_small(x, x, ctx); return kk_integer_sqr_generic(x, ctx); } @@ -972,73 +972,73 @@ static inline kk_integer_t kk_integer_neg_small(kk_integer_t x, kk_context_t* ct } static inline kk_integer_t kk_integer_neg(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return kk_integer_neg_small(x, ctx); + if kk_likely(kk_is_smallint(x)) return kk_integer_neg_small(x, ctx); return kk_integer_neg_generic(x, ctx); } static inline kk_integer_t kk_integer_abs(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) < 0 ? kk_integer_neg_small(x, ctx) : x); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) < 0 ? kk_integer_neg_small(x, ctx) : x); return (kk_integer_signum_generic_bigint(x) < 0 ? kk_integer_neg_generic(x, ctx) : x); } static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { #if KK_INT_ARITHMETIC == KK_INT_USE_RENO if (_kk_integer_value(x) == _kk_integer_value(y)) return 0; - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { if (_kk_integer_value(x) > _kk_integer_value(y)) return 1; - if (kk_likely(kk_is_smallint(y))) return -1; + if kk_likely(kk_is_smallint(y)) return -1; } #else - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); #endif return kk_integer_cmp_generic_borrow(x, y, ctx); } static inline bool kk_integer_lt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) < _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) == -1); } static inline bool kk_integer_lt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) < _kk_integer_value(y)); return (kk_integer_cmp_generic(x, y, ctx) == -1); } static inline bool kk_integer_lte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) <= _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) <= 0); } static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) > _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) == 1); } static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) > _kk_integer_value(y)); return (kk_integer_cmp_generic(x, y, ctx) == 1); } static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { #if 0 // KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) >= _kk_integer_value(y)); #else - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) >= _kk_integer_value(y)); #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) >= 0); } static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; - if (kk_likely(kk_is_smallint(x))) return false; - //if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small + if kk_likely(kk_is_smallint(x)) return false; + //if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic_borrow(x, y, ctx) == 0); } static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; - if (kk_likely(kk_is_smallint(x))) return false; - // if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small + if kk_likely(kk_is_smallint(x)) return false; + // if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic(x, y, ctx) == 0); } @@ -1051,32 +1051,32 @@ static inline bool kk_integer_neq(kk_integer_t x, kk_integer_t y, kk_context_t* } static inline bool kk_integer_is_even(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)&0x04)==0); + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)&0x04)==0); return kk_integer_is_even_generic(x, ctx); } static inline bool kk_integer_is_odd(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)&0x04)!=0); + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)&0x04)!=0); return !kk_integer_is_even_generic(x, ctx); } static inline int kk_integer_signum_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)>_kk_integer_value(kk_integer_zero)) - (_kk_integer_value(x)<0)); + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)>_kk_integer_value(kk_integer_zero)) - (_kk_integer_value(x)<0)); return kk_integer_signum_generic_bigint(x); } static inline bool kk_integer_is_pos_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(kk_integer_zero)); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) > _kk_integer_value(kk_integer_zero)); return (kk_integer_signum_generic_bigint(x) > 0); } static inline bool kk_integer_is_neg_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x)<0); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x)<0); return (kk_integer_signum_generic_bigint(x) < 0); } static inline kk_integer_t kk_integer_max(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x)>=_kk_integer_value(y) ? x : y); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)>=_kk_integer_value(y) ? x : y); if (kk_integer_gte_borrow(x, y, ctx)) { kk_integer_drop(y, ctx); return x; } @@ -1086,7 +1086,7 @@ static inline kk_integer_t kk_integer_max(kk_integer_t x, kk_integer_t y, kk_con } static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); if (kk_integer_lte_borrow(x, y, ctx)) { kk_integer_drop(y, ctx); return x; } @@ -1101,7 +1101,7 @@ static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_con ---------------------------------------------------------------------------------*/ static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); @@ -1115,7 +1115,7 @@ static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { } static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ctx) { // used for cfc field of evidence - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); @@ -1129,7 +1129,7 @@ static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ct } static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); @@ -1143,7 +1143,7 @@ static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { } static inline int64_t kk_integer_clamp64_borrow(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); @@ -1172,7 +1172,7 @@ static inline int16_t kk_integer_clamp_int16(kk_integer_t x, kk_context_t* ctx) } static inline size_t kk_integer_clamp_size_t(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); #if (KK_SMALLINT_MAX > SIZE_MAX) return (i < 0 ? 0 : (i > SIZE_MAX ? SIZE_MAX : (size_t)i)); @@ -1234,7 +1234,7 @@ static inline kk_intx_t kk_integer_clamp_borrow(kk_integer_t x, kk_context_t* ct } static inline double kk_integer_as_double(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (double)(kk_smallint_from_integer(x)); + if kk_likely(kk_is_smallint(x)) return (double)(kk_smallint_from_integer(x)); return kk_integer_as_double_generic(x,ctx); } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index b0b761569..d8783fecb 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -104,6 +104,9 @@ #endif #ifdef __cplusplus +#if (__cplusplus >= 202002L) +#define KK_CPP20 1 +#endif #if (__cplusplus >= 201703L) #define KK_CPP17 1 #endif @@ -143,8 +146,6 @@ #pragma GCC diagnostic ignored "-Wunused-variable" #pragma GCC diagnostic ignored "-Wunused-value" #pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals -#define kk_unlikely(h) __builtin_expect((h),0) -#define kk_likely(h) __builtin_expect((h),1) #define kk_decl_const __attribute__((const)) // reads no global state at all #define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects #define kk_decl_noinline __attribute__((noinline)) @@ -157,8 +158,6 @@ #pragma warning(disable:4068) // unknown pragma #pragma warning(disable:4996) // POSIX name deprecated #pragma warning(disable:26812) // the enum type is unscoped (in C++) -#define kk_unlikely(x) (x) -#define kk_likely(x) (x) #define kk_decl_const #define kk_decl_pure #define kk_decl_noinline __declspec(noinline) @@ -168,8 +167,6 @@ #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif #else -#define kk_unlikely(h) (h) -#define kk_likely(h) (h) #define kk_decl_const #define kk_decl_pure #define kk_decl_noinline @@ -177,6 +174,17 @@ #define kk_decl_thread __thread #endif +#if defined(__GNUC__) || defined(__clang__) +#define kk_unlikely(x) (__builtin_expect(!!(x),false)) +#define kk_likely(x) (__builtin_expect(!!(x),true)) +#elif (defined(__cplusplus) && (__cplusplus >= 202002L)) || (defined(_MSVC_LANG) && _MSVC_LANG >= 202002L) +#define kk_unlikely(x) (x) [[unlikely]] +#define kk_likely(x) (x) [[likely]] +#else +#define kk_unlikely(x) (x) +#define kk_likely(x) (x) +#endif + // Assertions; kk_assert_internal is only enabled when KK_DEBUG_FULL is defined #define kk_assert(x) assert(x) #ifdef KK_DEBUG_FULL @@ -283,11 +291,11 @@ typedef int32_t kk_off_t; // We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` bytes. static inline kk_ssize_t kk_to_ssize_t(size_t sz) { kk_assert(sz <= KK_SSIZE_MAX); - return (kk_likely(sz <= KK_SSIZE_MAX) ? (kk_ssize_t)sz : KK_SSIZE_MAX); + return kk_likely(sz <= KK_SSIZE_MAX) ? (kk_ssize_t)sz : KK_SSIZE_MAX; } static inline size_t kk_to_size_t(kk_ssize_t sz) { kk_assert(sz >= 0); - return (kk_likely(sz >= 0) ? (size_t)sz : 0); + return kk_likely(sz >= 0) ? (size_t)sz : 0; } #if defined(NDEBUG) @@ -314,7 +322,7 @@ typedef uint64_t kk_uintx_t; #define PRIuUX PRIu64 #define PRIxUX PRIx64 #define PRIXUX PRIX64 -#elif (INT_MAX > INT16_MAX && (LONG_MAX == INT32_MAX) || (SIZE_MAX == UINT32_MAX)) +#elif (INT_MAX > INT16_MAX && LONG_MAX == INT32_MAX) || (SIZE_MAX == UINT32_MAX) typedef int32_t kk_intx_t; typedef uint32_t kk_uintx_t; #define KK_IX(i) KK_I32(i) diff --git a/kklib/include/kklib/random.h b/kklib/include/kklib/random.h index 1dab8c65a..aec9894c3 100644 --- a/kklib/include/kklib/random.h +++ b/kklib/include/kklib/random.h @@ -24,7 +24,7 @@ kk_decl_export kk_random_ctx_t* kk_srandom_round(kk_context_t* ctx); // Initial randomness comes from the OS. static inline uint32_t kk_srandom_uint32(kk_context_t* ctx) { kk_random_ctx_t* rnd = ctx->srandom_ctx; - if (kk_unlikely(rnd == NULL || rnd->used >= 16)) { + if kk_unlikely(rnd == NULL || rnd->used >= 16) { rnd = kk_srandom_round(ctx); kk_assert_internal(rnd != NULL && rnd->used >= 0 && rnd->used < 16); } @@ -36,7 +36,7 @@ static inline uint32_t kk_srandom_uint32(kk_context_t* ctx) { static inline uint64_t kk_srandom_uint64(kk_context_t* ctx) { // return (((uint64_t)kk_srandom_uint32(ctx) << 32) | kk_srandom_uint32(ctx)); kk_random_ctx_t* rnd = ctx->srandom_ctx; - if (kk_unlikely(rnd == NULL || rnd->used >= 15)) { + if kk_unlikely(rnd == NULL || rnd->used >= 15) { rnd = kk_srandom_round(ctx); kk_assert_internal(rnd != NULL && rnd->used >= 0 && rnd->used < 15); } diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index bc84741dc..41e5fc2b0 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -299,7 +299,7 @@ kk_decl_export kk_char_t kk_utf8_read_validate(const uint8_t* s, kk_ssize_t* cou kk_decl_export kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count); static inline kk_char_t kk_utf8_read(const uint8_t* s, kk_ssize_t* count) { kk_char_t c = *s; - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; return c; } @@ -311,13 +311,13 @@ static inline kk_char_t kk_utf8_read(const uint8_t* s, kk_ssize_t* count) { // Number of bytes needed to represent a single code point kk_decl_export kk_ssize_t kk_utf8_lenx(kk_char_t c); static inline kk_ssize_t kk_utf8_len(kk_char_t c) { - return (kk_likely(c <= 0x7F) ? 1 : kk_utf8_lenx(c)); + return kk_likely(c <= 0x7F) ? 1 : kk_utf8_lenx(c); } // utf-8 encode a single codepoint kk_decl_export void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count); static inline void kk_utf8_write(kk_char_t c, uint8_t* s, kk_ssize_t* count) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; s[0] = (uint8_t)c; } diff --git a/kklib/src/box.c b/kklib/src/box.c index c9ddb9fbe..32b275100 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -18,7 +18,7 @@ typedef struct kk_boxed_intptr_s { } *boxed_intptr_t; intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (intptr_t)i; } @@ -50,7 +50,7 @@ typedef struct kk_boxed_int64_s { } *boxed_int64_t; int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (int64_t)i; } @@ -83,7 +83,7 @@ typedef struct kk_boxed_int32_s { } *boxed_int32_t; int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT32_MIN && i <= INT32_MAX) || kk_box_is_any(v)); return (int32_t)i; @@ -116,7 +116,7 @@ typedef struct kk_boxed_int16_s { } *boxed_int16_t; int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= int16_MIN && i <= int16_MAX) || kk_box_is_any(v)); return (int16_t)i; @@ -195,7 +195,7 @@ void* kk_cptr_raw_unbox(kk_box_t b) { kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { uintptr_t u = (uintptr_t)p; - if (kk_likely((u&1) == 0 && u <= KK_MAX_BOXED_UINT)) { // aligned pointer? + if kk_likely((u&1) == 0 && u <= KK_MAX_BOXED_UINT) { // aligned pointer? // box as value return _kk_box_new_value((kk_uintf_t)(u|1)); } diff --git a/kklib/src/integer.c b/kklib/src/integer.c index d27e25d02..1c4eb1397 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -800,7 +800,7 @@ static kk_bigint_t* bigint_add_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context_t* kk_ssize_t i; for (i = 0; i < cy; i++) { sum = x->digits[i] + y->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { carry = 1; sum -= BASE; } @@ -812,7 +812,7 @@ static kk_bigint_t* bigint_add_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context_t* // propagate the carry for (; carry != 0 && i < cx; i++) { sum = x->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { kk_assert_internal(sum==BASE && carry==1); // can only be at most BASE // carry stays 1; sum -= BASE; @@ -858,7 +858,7 @@ static kk_bigint_t* kk_bigint_add_abs_small(kk_bigint_t* x, kk_digit_t y, kk_con kk_ssize_t i; for (i = 0; carry!=0 && i < cx; i++) { sum = x->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { carry = 1; sum -= BASE; kk_assert_internal(sum < BASE); @@ -912,7 +912,7 @@ static kk_bigint_t* kk_bigint_sub_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context kk_ssize_t i; for (i = 0; i < cy; i++) { diff = x->digits[i] - borrow - y->digits[i]; - if (kk_unlikely(diff >= BASE)) { // unsigned wrap around + if kk_unlikely(diff >= BASE) { // unsigned wrap around borrow = 1; diff += BASE; // kk_assert_internal(diff >= 0); } @@ -924,7 +924,7 @@ static kk_bigint_t* kk_bigint_sub_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context // propagate borrow for (; borrow != 0 && i < cx; i++) { diff = x->digits[i] - borrow; - if (kk_unlikely(diff >= BASE)) { // unsigned wrap around + if kk_unlikely(diff >= BASE) { // unsigned wrap around // borrow stays 1; kk_assert_internal(diff==~((kk_digit_t)0)); diff += BASE; @@ -1735,20 +1735,20 @@ kk_integer_t kk_integer_div_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* static bool kk_digit_to_uint64_ovf(kk_digit_t d, uint64_t* u) { #if (BASE > UINT64_MAX) - if (kk_unlikely(d > UINT64_MAX)) return true; + if kk_unlikely(d > UINT64_MAX) return true; #endif *u = d; return false; } static bool kk_uint64_add_ovf(uint64_t x, uint64_t y, uint64_t* z) { - if (kk_unlikely(x > (UINT64_MAX - y))) return true; + if kk_unlikely(x > (UINT64_MAX - y)) return true; *z = x + y; return false; } static bool kk_uint64_mul_ovf(uint64_t x, uint64_t y, uint64_t* z) { - if (kk_unlikely(x > (UINT64_MAX / y))) return true; + if kk_unlikely(x > (UINT64_MAX / y)) return true; *z = x*y; return false; } diff --git a/kklib/src/random.c b/kklib/src/random.c index a1f887eff..c4b77450b 100644 --- a/kklib/src/random.c +++ b/kklib/src/random.c @@ -226,7 +226,7 @@ uint32_t kk_srandom_range_uint32(uint32_t max, kk_context_t* ctx) { uint32_t x = kk_srandom_uint32(ctx); uint64_t m = (uint64_t)x * (uint64_t)max; uint32_t l = (uint32_t)m; - if (kk_unlikely(l < max)) { + if kk_unlikely(l < max) { uint32_t threshold = (~max+1) % max; /* 2^32 % max == (2^32 - max) % max == -max % max */ while (l < threshold) { x = kk_srandom_uint32(ctx); diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 04846085c..02b0357c1 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -25,7 +25,7 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { const kk_ssize_t scan_fsize = b->header.scan_fsize; if (scan_fsize==0) { // TODO: can we avoid raw object tests? - if (kk_unlikely(kk_tag_is_raw(kk_block_tag(b)))) { kk_block_free_raw(b,ctx); } + if kk_unlikely(kk_tag_is_raw(kk_block_tag(b))) { kk_block_free_raw(b,ctx); } kk_block_free(b,ctx); // deallocate directly if nothing to scan } else { @@ -116,7 +116,7 @@ static void kk_block_make_shared(kk_block_t* b) { kk_decl_noinline kk_block_t* kk_block_check_dup(kk_block_t* b, kk_refcount_t rc0) { kk_assert_internal(b!=NULL); kk_assert_internal(kk_refcount_is_thread_shared(rc0)); // includes KK_STUCK - if (kk_likely(rc0 > RC_STICKY)) { + if kk_likely(rc0 > RC_STICKY) { kk_atomic_dup(b); } // else sticky: no longer increment (or decrement) @@ -130,10 +130,10 @@ kk_decl_noinline void kk_block_check_drop(kk_block_t* b, kk_refcount_t rc0, kk_c kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { kk_block_drop_free(b, ctx); // no more references, free it. } - else if (kk_unlikely(rc0 <= RC_STICKY_DROP)) { + else if kk_unlikely(rc0 <= RC_STICKY_DROP) { // sticky: do not drop further } else { @@ -152,7 +152,7 @@ kk_decl_noinline kk_reuse_t kk_block_check_drop_reuse(kk_block_t* b, kk_refcount kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { // no more references, reuse it. kk_ssize_t scan_fsize = kk_block_scan_fsize(b); for (kk_ssize_t i = 0; i < scan_fsize; i++) { @@ -174,10 +174,10 @@ kk_decl_noinline void kk_block_check_decref(kk_block_t* b, kk_refcount_t rc0, kk kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { kk_free(b,ctx); // no more references, free it (without dropping children!) } - else if (kk_unlikely(rc0 <= RC_STICKY_DROP)) { + else if kk_unlikely(rc0 <= RC_STICKY_DROP) { // sticky: do not decrement further } else { @@ -215,7 +215,7 @@ static bool kk_block_decref_no_free(kk_block_t* b) { if (rc==0) { return true; } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { return (rc <= RC_STICKY_DROP ? false : block_thread_shared_decref_no_free(b)); } else { @@ -244,7 +244,7 @@ static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t f uint8_t v_scan_fsize = child->header.scan_fsize; if (v_scan_fsize == 0) { // free leaf nodes directly and pretend it was not a ptr field - if (kk_unlikely(kk_tag_is_raw(kk_block_tag(child)))) { kk_block_free_raw(child, ctx); } // potentially call custom `free` function on the data + if kk_unlikely(kk_tag_is_raw(kk_block_tag(child))) { kk_block_free_raw(child, ctx); } // potentially call custom `free` function on the data kk_block_free(child,ctx); } else { @@ -342,7 +342,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t } // ------- move up along the parent chain ------------ - while (kk_likely(parent != NULL)) { + while kk_likely(parent != NULL) { // go up to parent uint8_t i = kk_block_field_idx(parent); scan_fsize = parent->header.scan_fsize; @@ -445,7 +445,7 @@ static kk_decl_noinline void kk_block_mark_shared_rec(kk_block_t* b, const kk_ss if (depth < MAX_RECURSE_DEPTH) { kk_block_make_shared(b); kk_ssize_t i = 0; - if (kk_unlikely(scan_fsize >= KK_SCAN_FSIZE_MAX)) { + if kk_unlikely(scan_fsize >= KK_SCAN_FSIZE_MAX) { scan_fsize = (kk_ssize_t)kk_intf_unbox(kk_block_field(b, 0)); i++; // skip scan field } diff --git a/kklib/src/string.c b/kklib/src/string.c index 04dea80e0..395e75bc6 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -121,7 +121,7 @@ kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx) { --------------------------------------------------------------------------------------------------*/ kk_ssize_t kk_utf8_lenx(kk_char_t c) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { return 1; } else if (c <= 0x07FF) { @@ -144,7 +144,7 @@ kk_ssize_t kk_utf8_lenx(kk_char_t c) { } void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; s[0] = (uint8_t)c; return; @@ -181,7 +181,7 @@ void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count) { kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count) { kk_char_t b = *s; kk_assert_internal(b >= 0); // shift left is not UB on b kk_char_t c; - if (kk_likely(b <= 0x7F)) { + if kk_likely(b <= 0x7F) { *count = 1; c = b; // fast path ASCII } @@ -237,7 +237,7 @@ static inline bool kk_char_is_raw(kk_char_t c) { // invalid so they can be decoded back into the raw sequence) kk_char_t kk_utf8_read_validate(const uint8_t* s, kk_ssize_t* count, kk_ssize_t* vcount, bool qutf8_identity) { uint8_t b = s[0]; - if (kk_likely(b <= 0x7F)) { + if kk_likely(b <= 0x7F) { *count = 1; return b; // ASCII fast path } @@ -286,7 +286,7 @@ static bool kk_qutf8_validate(kk_ssize_t len, const uint8_t* s, bool qutf8_ident while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { p++; vlen++; } @@ -330,7 +330,7 @@ static kk_string_t kk_qutf8_convert_from_invalid(kk_ssize_t len, const uint8_t* const uint8_t* p = s; const uint8_t* end = s + len; while (p < end) { - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { *t++ = *p++; } else { @@ -410,7 +410,7 @@ const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_con while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { p++; } else { @@ -438,7 +438,7 @@ const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_con while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { *q++ = *p++; } else { diff --git a/kklib/src/vector.c b/kklib/src/vector.c index 89ca30205..199066381 100644 --- a/kklib/src/vector.c +++ b/kklib/src/vector.c @@ -51,11 +51,11 @@ kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx) { } kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); kk_vector_t v = kk_vector_unbox(b, ctx); - if(kk_unlikely(! kk_datatype_is_unique(v))) { + if kk_unlikely(!kk_datatype_is_unique(v)) { // the old v is dropped by kk_ref_set_borrow v = kk_vector_copy(kk_vector_dup(v), ctx); kk_ref_set_borrow(r, kk_vector_box(v, ctx), ctx); diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 6d027a410..57f2fb119 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -664,7 +664,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount else -} vcat((if not (isConAsJust conRepr) then [] else let arg = ppName (fst (head (conInfoParams con))) - in [text "if (kk_likely(!kk_box_is_maybe(" <.> arg <.> text "))) { return kk_datatype_as_Just(" <.> arg <.> text "); }" + in [text "if kk_likely(!kk_box_is_maybe(" <.> arg <.> text ")) { return kk_datatype_as_Just(" <.> arg <.> text "); }" ]) ++ [text "struct" <+> nameDoc <.> text "*" <+> tmp <+> text "=" @@ -1422,7 +1422,9 @@ genGuard result (Guard guard expr) parensIf :: Doc -> Doc -- avoid parens if already parenthesized parensIf d - = if (dstartsWith d "(" && dendsWith d ")") then d else parens d + = if ((dstartsWith d "(" && dendsWith d ")") || + dstartsWith d "kk_likely") -- for genUniqueCall + then d else parens d genPattern :: Bool -> TNames -> [(Doc,Pattern)] -> Asm Doc -> Asm Doc From a3825ba60f6a5545bd9bbd419e2bee39879b6289 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 27 Nov 2022 13:42:58 -0800 Subject: [PATCH 086/233] improved recursive drop function --- kklib/src/refcount.c | 115 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 99 insertions(+), 16 deletions(-) diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 02b0357c1..2e306bef9 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -233,26 +233,25 @@ static bool kk_block_decref_no_free(kk_block_t* b) { // (and it is faster than a recursive version so we only have a stackless free) //----------------------------------------------------------------------------------------- -// Check if a field `i` in a block `b` should be freed, i.e. it is heap allocated with a refcount of 0. -// Optimizes by already freeing leaf blocks that are heap allocated but have no scan fields. -static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) -{ - kk_box_t v = kk_block_field(b, field); +// Check if a field `i` in a block `b` should be freed, i.e. it is heap allocated with a refcount of 0. +// Optimizes by already freeing leaf blocks that are heap allocated but have no scan fields. + +static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) { + kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { - kk_block_t* child = kk_ptr_unbox(v); + kk_block_t* child = kk_ptr_unbox(v); if (kk_block_decref_no_free(child)) { - uint8_t v_scan_fsize = child->header.scan_fsize; - if (v_scan_fsize == 0) { - // free leaf nodes directly and pretend it was not a ptr field - if kk_unlikely(kk_tag_is_raw(kk_block_tag(child))) { kk_block_free_raw(child, ctx); } // potentially call custom `free` function on the data - kk_block_free(child,ctx); - } - else { - return child; + uint8_t v_scan_fsize = child->header.scan_fsize; + if (v_scan_fsize == 0) { // free leaf nodes directly and pretend it was not a ptr field + if kk_unlikely(kk_tag_is_raw(kk_block_tag(child))) { kk_block_free_raw(child,ctx); } // potentially call custom `free` function on the data + kk_block_free(child,ctx); + } + else { + return child; } } } - return NULL; + return NULL; } @@ -279,6 +278,90 @@ static kk_decl_noinline void kk_block_drop_free_large_rec(kk_block_t* b, kk_cont // Recursively free a block and drop its children without using stack space static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t* ctx) +{ + kk_assert_internal(b->header.scan_fsize > 0); + kk_block_t* parent = NULL; + uint8_t scan_fsize; + uint8_t i; // current field + + // ------- drop the children and free the block b ------------ + drop_free_block: + scan_fsize = b->header.scan_fsize; + kk_assert_internal(kk_block_refcount(b) == 0); + kk_assert_internal(scan_fsize > 0); // due to kk_block_should_free + if (scan_fsize == 1) { + // if just one field, we can free directly and continue with the child + kk_block_t* next = kk_block_field_should_free(b, 0, ctx); + kk_block_free(b,ctx); + if (next != NULL) { + b = next; + goto drop_free_block; + } + // goto continue_with_parent; // fallthrough + } + else if (scan_fsize == 2 && !kk_box_is_non_null_ptr(kk_block_field(b,0))) { + // optimized code for lists/nodes with boxed first element + kk_block_t* next = kk_block_field_should_free(b, 1, ctx); + kk_block_free(b,ctx); + if (next != NULL) { + b = next; + goto drop_free_block; + } + // goto continue_with_parent; // fallthrough + } + else if kk_unlikely(scan_fsize == KK_SCAN_FSIZE_MAX) { + kk_assert_internal(scan_fsize == KK_SCAN_FSIZE_MAX); + kk_block_drop_free_large_rec(b, ctx); + // goto continue_with_parent; // fallthrough + } + else { + // small block more than 1 field (but less then KK_SCAN_FSIZE_MAX) + i = 0; + + scan_fields: // i points to the starting field to scan + kk_assert_internal(i < scan_fsize); + // drop each field + do { + kk_block_t* child = kk_block_field_should_free(b, i, ctx); + i++; + if (child != NULL) { + // go down into the child + if (i < scan_fsize) { + // save our progress to continue here later (when moving up along the parent chain) + kk_block_field_set(b, 0, _kk_box_new_ptr(parent)); // set parent (use low-level box as parent could be NULL) + kk_block_field_idx_set(b,i); + parent = b; + } + else { + // the last field: free the block and continue with the child leaving the parent unchanged + kk_block_free(b,ctx); + } + // and continue with the child + b = child; + goto drop_free_block; + } + } while (i < scan_fsize); + kk_block_free(b,ctx); + // goto continue_with_parent; // fallthrough + } + + // ------- move up along the parent chain ------------ + // continue_with_parent: + if (parent != NULL) { + b = parent; + parent = _kk_box_ptr( kk_block_field(parent, 0) ); // low-level unbox as it can be NULL + scan_fsize = b->header.scan_fsize; + i = kk_block_field_idx(b); + kk_assert_internal(i < scan_fsize); + goto scan_fields; + } + + // done: +} + +#if 0 +// Recursively free a block and drop its children without using stack space +static kk_decl_noinline void kk_block_drop_free_rec_old(kk_block_t* b, kk_context_t* ctx) { kk_assert_internal(b->header.scan_fsize > 0); kk_block_t* parent = NULL; @@ -374,7 +457,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t } // done } - +#endif //----------------------------------------------------------------------------------------- // Mark a block and all children recursively as thread shared From 0429b114df0ad5acf95e6a42e1ce25eb6c544d88 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 27 Nov 2022 13:43:06 -0800 Subject: [PATCH 087/233] update mimalloc --- kklib/include/kklib.h | 2 +- kklib/mimalloc | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 72e5e62e7..75b62e034 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 93 // modify on changes to trigger recompilation +#define KKLIB_BUILD 95 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/mimalloc b/kklib/mimalloc index 3d6017de7..447c2f18c 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit 3d6017de7c1338bebbb9a4c0e7b8329af202b2e6 +Subproject commit 447c2f18c56cef4455ab9db1d5f713f6203753a8 From c43d900418822746c46a60c338bff2a611ea3d95 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 27 Nov 2022 13:56:01 -0800 Subject: [PATCH 088/233] nicer recursive drop code --- kklib/include/kklib.h | 2 +- kklib/src/refcount.c | 20 ++++++++++---------- koka.cabal | 6 +++--- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 75b62e034..2934cda96 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 95 // modify on changes to trigger recompilation +#define KKLIB_BUILD 94 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 2e306bef9..66b025460 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -285,7 +285,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t uint8_t i; // current field // ------- drop the children and free the block b ------------ - drop_free_block: + move_down: scan_fsize = b->header.scan_fsize; kk_assert_internal(kk_block_refcount(b) == 0); kk_assert_internal(scan_fsize > 0); // due to kk_block_should_free @@ -295,9 +295,9 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t kk_block_free(b,ctx); if (next != NULL) { b = next; - goto drop_free_block; + goto move_down; } - // goto continue_with_parent; // fallthrough + // goto move_up; // fallthrough } else if (scan_fsize == 2 && !kk_box_is_non_null_ptr(kk_block_field(b,0))) { // optimized code for lists/nodes with boxed first element @@ -305,14 +305,14 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t kk_block_free(b,ctx); if (next != NULL) { b = next; - goto drop_free_block; + goto move_down; } - // goto continue_with_parent; // fallthrough + // goto move_up; // fallthrough } else if kk_unlikely(scan_fsize == KK_SCAN_FSIZE_MAX) { kk_assert_internal(scan_fsize == KK_SCAN_FSIZE_MAX); kk_block_drop_free_large_rec(b, ctx); - // goto continue_with_parent; // fallthrough + // goto move_up; // fallthrough } else { // small block more than 1 field (but less then KK_SCAN_FSIZE_MAX) @@ -338,15 +338,15 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t } // and continue with the child b = child; - goto drop_free_block; + goto move_down; } } while (i < scan_fsize); kk_block_free(b,ctx); - // goto continue_with_parent; // fallthrough + // goto move_up; // fallthrough } // ------- move up along the parent chain ------------ - // continue_with_parent: + // move_up: if (parent != NULL) { b = parent; parent = _kk_box_ptr( kk_block_field(parent, 0) ); // low-level unbox as it can be NULL @@ -356,7 +356,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t goto scan_fields; } - // done: + // done } #if 0 diff --git a/koka.cabal b/koka.cabal index e27aaa65b..ce7e76ea7 100644 --- a/koka.cabal +++ b/koka.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.12 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -149,11 +149,11 @@ executable koka , process , text , time + default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS if os(darwin) cpp-options: -DDARWIN - default-language: Haskell2010 test-suite koka-test type: exitcode-stdio-1.0 From c39fedc2546e9c5737ab49567b23f5f15245bed5 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 28 Nov 2022 14:23:15 -0800 Subject: [PATCH 089/233] use tail recursive mark index that does not interfere with TRMC context path indices --- kklib/include/kklib.h | 2 +- kklib/src/refcount.c | 106 +++++++++++++++++++++++---------- test/bench/koka/binarytrees.kk | 4 ++ 3 files changed, 79 insertions(+), 33 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 2934cda96..75b62e034 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 94 // modify on changes to trigger recompilation +#define KKLIB_BUILD 95 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 66b025460..b7f73b3b4 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -571,61 +571,103 @@ static kk_decl_noinline void kk_block_mark_shared_recx_large(kk_block_t* b, kk_c kk_block_make_shared(b); } +// Unfortunately, we cannot use the _field_idx as the index for marking +// as we also use it for tail recursion context paths. Such TRMC structure may +// be captured under a lambda (by yielding for example) and that might become +// thread shared and we cannot overwrite such indices. +// (This is unlike freeing where we can use it as we are freeing it anyways) +// So, we steal 8 bits of an unshared reference count. If the reference count +// is too large we just set it to RC_STUCK when it gets marked. +#define KK_RC_MARK_MAX KK_U32(0x7FFFFF) + +static void kk_block_mark_idx_prepare(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(rc <= RC_STUCK); // not thread shared already + if (rc > KK_RC_MARK_MAX) { rc = KK_RC_MARK_MAX; } // if rc is too large, cap it + rc = (rc << 8); // make room for 8-bit mark index + kk_assert_internal(rc < RC_STUCK); + kk_assert_internal((rc & 0xFF) == 0); + kk_block_refcount_set(b, rc); +} + +static void kk_block_mark_idx_done(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(rc <= RC_STUCK); // not thread shared already + rc = kk_shr32(rc, 8); + if (rc >= KK_RC_MARK_MAX) { rc = RC_STUCK; } // make it sticky if it was too large to contain an index + kk_block_refcount_set(b, rc); +} + +static void kk_block_mark_idx_set(kk_block_t* b, uint8_t i) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(rc <= RC_STUCK); // not thread shared already + rc = ((rc & ~0xFF) | i); + kk_block_refcount_set(b, rc); +} + +static uint8_t kk_block_mark_idx(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(rc <= RC_STUCK); // not thread shared already + return (uint8_t)rc; +} + // Stackless marking by using pointer reversal static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context_t* ctx) { + fprintf(stderr, "mark shared recx\n"); kk_block_t* parent = NULL; if (kk_block_is_thread_shared(b)) return; if (b->header.scan_fsize == 0) return; - uint8_t i = 0; - uint8_t scan_fsize = b->header.scan_fsize; + uint8_t i; + uint8_t scan_fsize; - // ---- marking fields ----- -markfields: - kk_assert_internal(scan_fsize > 0); +recurse: + kk_assert_internal(!kk_block_is_thread_shared(b)); // due to kk_block_field_should_mark + scan_fsize = b->header.scan_fsize; if (scan_fsize == KK_SCAN_FSIZE_MAX) { - // recurse over the stack for large objects (vectors) + // stack recurse over the stack for large objects (vectors) kk_block_mark_shared_recx_large(b, ctx); } else { - do { + i = 0; + kk_block_mark_idx_prepare(b); + + // ---- marking fields starting at field `i` upto `scan_fsize` ----- +markfields: + kk_assert_internal(scan_fsize > 0); + kk_assert_internal(i <= scan_fsize); + while (i < scan_fsize) { kk_block_t* child = kk_block_field_should_mark(b, i, ctx); i++; if (child != NULL) { - // move down - // remember our state and link back to the parent - kk_block_field_set(b, i-1, _kk_box_new_ptr(parent)); // low-level box as parent can be NULL + // visit the child, but remember our state and link back to the parent + // note: we cannot optimize for the last child as in freeing as we need to restore all parent fields + kk_block_field_set(b, i - 1, _kk_box_new_ptr(parent)); // low-level box as parent can be NULL + kk_block_mark_idx_set(b, i); parent = b; - kk_block_field_idx_set(parent,i); b = child; - i = 0; - scan_fsize = b->header.scan_fsize; - goto markfields; + goto recurse; } - } while (i < scan_fsize); + } + kk_block_mark_idx_done(b); kk_block_make_shared(b); } - //--- moving back up ------------------ - while (parent != NULL) { + //--- moving back up along the parent chain ------------------ + if (parent != NULL) { // move up - i = kk_block_field_idx(parent); + i = kk_block_mark_idx(parent); + scan_fsize = parent->header.scan_fsize; + kk_assert_internal(i > 0 && i <= scan_fsize); kk_block_t* pparent = _kk_box_ptr( kk_block_field(parent, i-1) ); // low-level unbox on parent - kk_block_field_set(parent, i-1, kk_ptr_box(b)); // restore original pointer + kk_block_field_set(parent, i-1, kk_ptr_box(b)); // restore original pointer b = parent; parent = pparent; - // and continue visiting the fields - scan_fsize = b->header.scan_fsize; - if (i >= scan_fsize) { - kk_assert_internal(i == scan_fsize); - // done, keep moving up - kk_block_make_shared(b); - } - else { - // mark the rest of the fields starting at `i` upto `scan_fsize` - goto markfields; - } + kk_assert_internal(!kk_block_is_thread_shared(b)); + // mark the rest of the fields starting at `i` upto `scan_fsize` + goto markfields; } + // done } @@ -672,8 +714,8 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { #if !defined(KK_CTAIL_NO_CONTEXT_PATH) kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res))); - kk_box_t cres; // copied result context - kk_box_t* next = NULL; // pointer to the context path field in the parent block + kk_box_t cres = kk_box_null; // copied result context + kk_box_t* next = NULL; // pointer to the context path field in the parent block for( kk_box_t cur = res; kk_box_is_ptr(cur); cur = *next ) { kk_block_t* b = kk_ptr_unbox(cur); const kk_ssize_t field = kk_block_field_idx(b) - 1; diff --git a/test/bench/koka/binarytrees.kk b/test/bench/koka/binarytrees.kk index f817ad9dc..519d628e0 100644 --- a/test/bench/koka/binarytrees.kk +++ b/test/bench/koka/binarytrees.kk @@ -159,11 +159,15 @@ pub fun main() // allocate and free the stretch tree val stretch-depth = max-depth.inc show( "stretch tree", stretch-depth, make(stretch-depth).check ) + // allocate long lived tree // val long = make(max-depth) val long = make(max-depth) + // test thread shared marking + // show("long lived tree in another thread", max-depth, task{ long.check }.await ) + // allocate and free many trees in parallel val trees = gen-depth( min-depth, max-depth ) trees.foreach fn((count,depth,csum)) From d55b9fb1f050013035c4ab7bfbdd699e0ef1a4a7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 6 Dec 2022 20:28:03 -0800 Subject: [PATCH 090/233] wip: initial basetype implementation with pointer compression support --- kklib/include/kklib.h | 528 ++++++++++++++++++++++----------- kklib/include/kklib/box.h | 182 ++++++------ kklib/include/kklib/bytes.h | 44 +-- kklib/include/kklib/integer.h | 56 ++-- kklib/include/kklib/platform.h | 108 +++++-- kklib/include/kklib/string.h | 66 +++-- kklib/src/box.c | 86 +++--- kklib/src/bytes.c | 70 ++--- kklib/src/init.c | 23 +- kklib/src/integer.c | 72 ++--- kklib/src/os.c | 20 +- kklib/src/ref.c | 12 +- kklib/src/refcount.c | 32 +- kklib/src/string.c | 86 +++--- kklib/src/thread.c | 34 +-- kklib/src/vector.c | 23 +- kklib/test/main.c | 278 ++++++++--------- 17 files changed, 989 insertions(+), 731 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 75b62e034..d794691b0 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -142,24 +142,46 @@ static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_ Box, Integer, Datatype --------------------------------------------------------------------------------------*/ +// We generally tag boxed values; the least-significant bit is clear for heap pointers (`kk_ptr_t == kk_block_t*`), +// while the bit is set for values. +#define KK_TAG_BITS (1) +#define KK_TAG_MASK ((1<= 8) -typedef int32_t kk_field_t; - -static inline kk_box_t kk_field_uncompress(void* blk, kk_field_t field) { - kk_box_t b = { (uintptr_t)((intptr_t)blk + field) }; - return b; -} - -static inline kk_field_t kk_field_compress(void* blk, kk_box_t x) { - intptr_t diff = (intptr_t)(x.box) - (intptr_t)blk); - assert_internal(diff >= INT32_MIN && diff <= INT32_MAX); - return (int32_t)diff; -} - -#define kk_field_tp(tp) kk_field_t -#define kk_field(tp,blk,field_name,ctx) kk_field_uncompress(blk,(blk)->field_name) -#define kk_field_set(tp,blk,field_name,x,ctx) (blk)->field_name = kk_field_compress(blk,(blk)->field_name) - -#else -typedef kk_box_t kk_field_t; - -#define kk_field_tp(tp) kk_field_t -#define kk_field(tp,blk,field_name,ctx) (blk)->field_name -#define kk_field_set(tp,blk,field_name,x,ctx) (blk)->field_name = x -#endif /*-------------------------------------------------------------------------------------- Blocks @@ -318,29 +315,26 @@ static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { b->header._field_idx = idx; } -#if (KK_INTPTR_SIZE==8) -#define KK_BLOCK_INVALID KK_UP(0xDFDFDFDFDFDFDFDF) -#else -#define KK_BLOCK_INVALID KK_UP(0xDFDFDFDF) -#endif static inline void kk_block_set_invalid(kk_block_t* b) { #ifdef KK_DEBUG_FULL const kk_ssize_t scan_fsize = kk_block_scan_fsize(b); - const kk_box_t inv = { KK_BLOCK_INVALID }; - for (kk_ssize_t i = -1; i < scan_fsize; i++) { - kk_block_field_set(b, i, inv); + const kk_ssize_t bsize = (sizeof(kk_box_t) * scan_fsize) + (b->header.scan_fsize == KK_SCAN_FSIZE_MAX ? sizeof(kk_block_large_t) : sizeof(kk_block_t)); + uint8_t* p = (uint8_t*)b; + for (kk_ssize_t i = 0; i < bsize; i++) { + p[i] = 0xDF; } #else kk_unused(b); #endif -} +} static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { - return (b != NULL && ((uintptr_t)b&1)==0 && kk_block_field(b, 0).box != KK_BLOCK_INVALID); // already freed! + return (b != NULL && ((intptr_t)b & 1) == 0 && *((int64_t*)b) != KK_I64(0xDFDFDFDFDFDFDFDF)); // already freed! } + /*-------------------------------------------------------------------------------------- The thread local context as `kk_context_t` This is passed by the code generator as an argument to every function so it can @@ -362,11 +356,12 @@ typedef void* kk_heap_t; // A function has as its first field a pointer to a C function that takes the // `kk_function_t` itself as a first argument. The following fields are the free variables. -typedef struct kk_function_s { +struct kk_function_s { kk_block_t _block; - kk_box_t fun; + kk_box_t fun; // kk_kkfun_ptr_t // followed by free variables -} *kk_function_t; +}; +typedef kk_basetype_t kk_function_t; // A vector is an array of boxed values, or an empty singleton typedef kk_datatype_t kk_vector_t; @@ -386,10 +381,11 @@ typedef struct kk_duration_s { // Box any is used when yielding -typedef struct kk_box_any_s { +struct kk_box_any_s { kk_block_t _block; kk_integer_t _unused; -} *kk_box_any_t; +}; +typedef kk_basetype_t kk_box_any_t; // Workers run in a task_group typedef struct kk_task_group_s kk_task_group_t; @@ -419,17 +415,18 @@ extern kk_ptr_t kk_evv_empty_singleton; // The thread local context. // The fields `yielding`, `heap` and `evv` should come first for efficiency typedef struct kk_context_s { - int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency - kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? - kk_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector - kk_yield_t yield; // inlined yield structure (for efficiency) - int32_t marker_unique; // unique marker generation - kk_block_t* delayed_free; // list of blocks that still need to be freed - kk_integer_t unique; // thread local unique number generation - size_t thread_id; // unique thread id - kk_box_any_t kk_box_any; // used when yielding as a value of any type - kk_function_t log; // logging function - kk_function_t out; // std output + int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency + const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? + const intptr_t heap_base; // mid point of the reserved heap address space (or 0 if the heap is not compressed) + kk_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector + kk_yield_t yield; // inlined yield structure (for efficiency) + int32_t marker_unique; // unique marker generation + kk_block_t* delayed_free; // list of blocks that still need to be freed + kk_integer_t unique; // thread local unique number generation + size_t thread_id; // unique thread id + kk_box_any_t kk_box_any; // used when yielding as a value of any type + kk_function_t log; // logging function + kk_function_t out; // std output kk_task_group_t* task_group; // task group for managing threads. NULL for the main thread. struct kk_random_ctx_s* srandom_ctx; // strong random using chacha20, initialized on demand @@ -675,7 +672,7 @@ static inline kk_block_t* kk_block_dup(kk_block_t* b) { kk_assert_internal(kk_block_is_valid(b)); const kk_refcount_t rc = kk_block_refcount(b); if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 - return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? + return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? } else { kk_block_refcount_set(b, rc+1); @@ -836,6 +833,7 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { --------------------------------------------------------------------------------------*/ //#define kk_basetype_tag(v) (kk_block_tag(&((v)->_block))) +/* #define kk_basetype_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) #define kk_basetype_is_unique(v) (kk_block_is_unique(&((v)->_block))) #define kk_basetype_as(tp,v) (kk_block_as(tp,&((v)->_block))) @@ -862,6 +860,195 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define kk_value_dup(v) (v) #define kk_value_drop(v,ctx) (void) #define kk_value_drop_reuse(v,ctx) (kk_reuse_null) +*/ + +#define kk_base_type_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) +#define kk_base_type_is_unique(v) (kk_block_is_unique(&((v)->_block))) +#define kk_base_type_as(tp,v) (kk_block_as(tp,&((v)->_block))) +#define kk_base_type_free(v,ctx) (kk_block_free(&((v)->_block),ctx)) +#define kk_base_type_decref(v,ctx) (kk_block_decref(&((v)->_block),ctx)) +#define kk_base_type_dup_as(tp,v) ((tp)kk_block_dup(&((v)->_block))) +#define kk_base_type_drop(v,ctx) (kk_block_dropi(&((v)->_block),ctx)) +#define kk_base_type_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_block),n,ctx)) +#define kk_base_type_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) +#define kk_base_type_reuse(v) (&((v)->_block)) +#define kk_base_type_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_block),x)) +#define kk_base_type_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) +#define kk_base_type_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) +#define kk_base_type_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) + + +#define kk_constructor_tag(v) (kk_block_tag(&((v)->_base._block))) +#define kk_constructor_is_unique(v) (kk_block_is_unique(&((v)->_base._block))) +#define kk_constructor_free(v,ctx) (kk_block_free(&((v)->_base._block),ctx)) +#define kk_constructor_dup_as(tp,v) (kk_block_dup_as(tp, &((v)->_base._block))) +#define kk_constructor_drop(v,ctx) (kk_block_drop(&((v)->_base._block),ctx)) +#define kk_constructor_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_base._block).,n,ctx)) +#define kk_constructor_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_base._block),x)) + + +/*---------------------------------------------------------------------- + +----------------------------------------------------------------------*/ + +static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { + kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); +#if KK_COMPRESS + intptr_t i = (intptr_t)p - ctx->heap_base; + kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); + return _kk_make_ptr((kk_int_b)i); +#else + kk_unused(ctx); + return _kk_make_ptr((kk_intb_t)p); +#endif +} + +static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { + kk_assert_internal(kk_is_ptr(b)); +#if KK_COMPRESS + intptr_t i = ctx->heap_base + _kk_unmake_ptr(b); + return (kk_ptr_t)i; +#else + kk_unused(ctx); + return (kk_ptr_t)_kk_unmake_ptr(b); +#endif +} + +#define KK_INTF_BOX_BITS (KK_INTF_BITS-KK_TAG_BITS) +#define KK_INTF_BOX_MAX ((kk_intf_t)KK_INTF_MAX >> (KK_INTF_BITS - KK_INTF_BOX_BITS)) +#define KK_INTF_BOX_MIN (- KK_INTF_BOX_MAX - 1) + +static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { + kk_assert_internal(extra_shift >= 0); + kk_assert_internal((i & KK_TAG_MASK) == 0); + kk_assert_internal(i >= (KK_INTF_BOX_MIN / (KK_IF(1)<= 0); + kk_assert_internal(kk_is_value(b)); + kk_intb_t i = kk_sarb(_kk_unmake_value(b),KK_TAG_BITS + extra_shift); + return (kk_intf_t)i; +} + + + +/*---------------------------------------------------------------------- + Base types are always pointers into the heap +----------------------------------------------------------------------*/ + +static inline kk_decl_const kk_basetype_t kk_basetype_from_ptr(kk_ptr_t p, kk_context_t* ctx) { + kk_basetype_t b = { kk_ptr_encode(p,ctx) }; + return b; +} + +static inline kk_decl_const bool kk_basetype_eq(kk_basetype_t x, kk_basetype_t y) { + return (x.bbox == y.bbox); +} + +static inline kk_decl_const bool kk_basetype_is_ptr(kk_basetype_t b) { + kk_assert_internal(kk_is_ptr(b.bbox)); + return true; +} + +static inline kk_decl_const kk_block_t* kk_basetype_as_ptr(kk_basetype_t b, kk_context_t* ctx) { + kk_unused(ctx); + kk_assert_internal(kk_basetype_is_ptr(b)); + return kk_ptr_decode(b.bbox,ctx); +} + +static inline kk_decl_pure kk_tag_t kk_basetype_tag(kk_basetype_t b, kk_context_t* ctx) { + return kk_block_tag(kk_basetype_as_ptr(b,ctx)); +} + +static inline kk_decl_pure bool kk_basetype_has_tag(kk_basetype_t b, kk_tag_t t, kk_context_t* ctx) { + return (kk_block_tag(kk_basetype_as_ptr(b,ctx)) == t); +} + +static inline bool kk_decl_pure kk_basetype_is_unique(kk_basetype_t b, kk_context_t* ctx) { + return kk_block_is_unique(kk_basetype_as_ptr(b,ctx)); +} + +static inline kk_basetype_t kk_basetype_dup(kk_basetype_t b, kk_context_t* ctx) { + kk_block_dup(kk_basetype_as_ptr(b,ctx)); + return b; +} + +static inline void kk_basetype_drop(kk_basetype_t b, kk_context_t* ctx) { + kk_block_drop(kk_basetype_as_ptr(b,ctx), ctx); +} + +static inline void kk_basetype_dropn(kk_basetype_t b, kk_ssize_t scan_fsize, kk_context_t* ctx) { + kk_assert_internal(scan_fsize > 0); + kk_block_dropn(kk_basetype_as_ptr(b,ctx), scan_fsize, ctx); +} + +static inline kk_basetype_t kk_basetype_dup_assert(kk_basetype_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(t); + kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); + return kk_basetype_dup(b, ctx); +} + +static inline void kk_basetype_drop_assert(kk_basetype_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(t); + kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); + kk_basetype_drop(b, ctx); +} + +static inline kk_reuse_t kk_basetype_dropn_reuse(kk_basetype_t b, kk_ssize_t scan_fsize, kk_context_t* ctx) { + kk_assert_internal(kk_basetype_is_ptr(b)); + return kk_block_dropn_reuse(kk_basetype_as_ptr(b,ctx), scan_fsize, ctx); +} + +static inline kk_reuse_t kk_basetype_reuse(kk_basetype_t b, kk_context_t* ctx) { + return kk_basetype_as_ptr(b,ctx); +} + +static inline void kk_basetype_free(kk_basetype_t b, kk_context_t* ctx) { + kk_free(kk_basetype_as_ptr(b,ctx), ctx); +} + +static inline void kk_basetype_decref(kk_basetype_t b, kk_context_t* ctx) { + kk_assert_internal(kk_basetype_is_ptr(b)); + kk_block_decref(kk_basetype_as_ptr(b,ctx), ctx); +} + +#define kk_basetype_from_base(b,ctx) (kk_basetype_from_ptr(&(b)->_block,ctx)) +#define kk_basetype_from_constructor(b,ctx) (kk_basetype_from_base(&(b)->_base,ctx)) +#define kk_basetype_as(tp,v,ctx) (kk_block_as(tp,kk_basetype_as_ptr(v,ctx))) +#define kk_basetype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_basetype_as_ptr(v,ctx),tag)) +#define kk_basetype_alloc(struct_tp,scan_fsize,tag,ctx) (kk_basetype_from_ptr(kk_block_alloc(kk_ssizeof(struct_tp),scan_fsize,tag,ctx),ctx)) + +#define kk_basetype_null { _kk_make_value(0) } + +static inline bool kk_basetype_is_null(kk_basetype_t b) { + return kk_is_value(b.bbox); +} + +static inline kk_basetype_t kk_basetype_unbox(kk_box_t bx) { + kk_basetype_t b = { bx.box }; + return b; +} + +static inline kk_basetype_t kk_basetype_unbox_assert(kk_box_t bx, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(ctx); + kk_basetype_t b = { bx.box }; + kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); + return b; +} + +static inline kk_box_t kk_basetype_box(kk_basetype_t b) { + kk_box_t bx = { b.bbox }; + return bx; +} + + +#define kk_basetype_unbox_as_assert(tp,b,tag,ctx) (kk_basetype_as_assert(tp,kk_basetype_unbox(b),tag,ctx)) +#define kk_basetype_unbox_as(tp,b,ctx) ((tp)kk_basetype_as(tp,kk_basetype_unbox(b),ctx)) + +#define kk_constructor_unbox_as(tp,b,tag) (kk_basetype_unbox_as_assert(tp,b,tag)) +#define kk_constructor_box(b) (kk_basetype_box(&(b)->_base)) /*---------------------------------------------------------------------- @@ -870,12 +1057,12 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { // create a singleton static inline kk_decl_const kk_datatype_t kk_datatype_from_tag(kk_tag_t t) { - kk_datatype_t d = { (((kk_uintf_t)t)<<2 | 1) }; + kk_datatype_t d = { kk_intf_encode((kk_intf_t)t,1) }; return d; } -static inline kk_decl_const kk_datatype_t kk_datatype_from_ptr(kk_ptr_t p) { - kk_datatype_t d = { (uintptr_t)p }; +static inline kk_decl_const kk_datatype_t kk_datatype_from_ptr(kk_ptr_t p, kk_context_t* ctx) { + kk_datatype_t d = { kk_ptr_encode(p, ctx) }; return d; } @@ -884,76 +1071,75 @@ static inline kk_decl_const bool kk_datatype_eq(kk_datatype_t x, kk_datatype_t y } static inline kk_decl_const bool kk_datatype_is_ptr(kk_datatype_t d) { - return ((((kk_uintf_t)d.dbox)&1) == 0); + return kk_is_ptr(d.dbox); } static inline kk_decl_const bool kk_datatype_is_singleton(kk_datatype_t d) { - return ((((kk_uintf_t)d.dbox)&1) == 1); + return kk_is_value(d.dbox); +} + +static inline kk_decl_const kk_block_t* kk_datatype_as_ptr(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return kk_ptr_decode(d.dbox,ctx); } -static inline kk_decl_pure kk_tag_t kk_datatype_tag(kk_datatype_t d) { +static inline kk_decl_pure kk_tag_t kk_datatype_tag(kk_datatype_t d, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return kk_block_tag((kk_ptr_t)d.dbox); + return kk_block_tag(kk_datatype_as_ptr(d,ctx)); } else { - return (kk_tag_t)(((kk_uintf_t)d.dbox) >> 2); + return (kk_tag_t)kk_intf_decode(d.dbox,1); } } -static inline kk_decl_pure bool kk_datatype_has_tag(kk_datatype_t d, kk_tag_t t) { + +static inline kk_decl_pure bool kk_datatype_has_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return (kk_block_tag((kk_ptr_t)d.dbox) == t); + return (kk_block_tag(kk_datatype_as_ptr(d,ctx)) == t); } else { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize if sizeof(kk_uintf_t) < sizeof(uintptr_t) ? + return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize ? } } -static inline kk_decl_pure bool kk_datatype_has_ptr_tag(kk_datatype_t d, kk_tag_t t) { - return (kk_datatype_is_ptr(d) && kk_block_tag((kk_ptr_t)d.dbox) == t); +static inline kk_decl_pure bool kk_datatype_has_ptr_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + return (kk_datatype_is_ptr(d) && kk_block_tag(kk_datatype_as_ptr(d,ctx)) == t); } static inline kk_decl_pure bool kk_datatype_has_singleton_tag(kk_datatype_t d, kk_tag_t t) { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize if sizeof(kk_uintf_t) < sizeof(uintptr_t) ? + return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize ? } - -static inline kk_decl_const kk_block_t* kk_datatype_as_ptr(kk_datatype_t d) { +static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - return (kk_ptr_t)d.dbox; -} - - -static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d) { - kk_assert_internal(kk_datatype_is_ptr(d)); //return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d))); - return kk_block_is_unique(kk_datatype_as_ptr(d)); + return kk_block_is_unique(kk_datatype_as_ptr(d,ctx)); } -static inline kk_datatype_t kk_datatype_dup(kk_datatype_t d) { - if (kk_datatype_is_ptr(d)) { kk_block_dup(kk_datatype_as_ptr(d)); } +static inline kk_datatype_t kk_datatype_dup(kk_datatype_t d, kk_context_t* ctx) { + if (kk_datatype_is_ptr(d)) { kk_block_dup(kk_datatype_as_ptr(d,ctx)); } return d; } static inline void kk_datatype_drop(kk_datatype_t d, kk_context_t* ctx) { - if (kk_datatype_is_ptr(d)) { kk_block_drop(kk_datatype_as_ptr(d),ctx); } + if (kk_datatype_is_ptr(d)) { kk_block_drop(kk_datatype_as_ptr(d,ctx), ctx); } } static inline void kk_datatype_dropn(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); kk_assert_internal(scan_fsize > 0); - kk_block_dropn(kk_datatype_as_ptr(d), scan_fsize, ctx); + kk_block_dropn(kk_datatype_as_ptr(d,ctx), scan_fsize, ctx); } -static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t) { +static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); - kk_assert_internal(kk_datatype_has_tag(d, t)); - return kk_datatype_dup(d); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return kk_datatype_dup(d, ctx); } static inline void kk_datatype_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); - kk_assert_internal(kk_datatype_has_tag(d, t)); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); kk_datatype_drop(d, ctx); } @@ -963,56 +1149,53 @@ static inline kk_reuse_t kk_datatype_dropn_reuse(kk_datatype_t d, kk_ssize_t sca return kk_reuse_null; } else { - return kk_block_dropn_reuse(kk_datatype_as_ptr(d), scan_fsize, ctx); + return kk_block_dropn_reuse(kk_datatype_as_ptr(d,ctx), scan_fsize, ctx); } } -static inline kk_reuse_t kk_datatype_reuse(kk_datatype_t d) { +static inline kk_reuse_t kk_datatype_reuse(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(!kk_datatype_is_singleton(d)); - return kk_datatype_as_ptr(d); - /* - if (kk_datatype_is_singleton(d)) { - return kk_reuse_null; - } - else { - return kk_datatype_as_ptr(d); - } - */ + return kk_datatype_as_ptr(d,ctx); } static inline void kk_datatype_free(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - kk_free(kk_datatype_as_ptr(d),ctx); - /* - if (kk_datatype_is_ptr(d)) { - kk_free(kk_datatype_as_ptr(d)); - } - */ + kk_free(kk_datatype_as_ptr(d,ctx), ctx); } static inline void kk_datatype_decref(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - kk_block_decref(kk_datatype_as_ptr(d), ctx); - /* - if (kk_datatype_is_ptr(d)) { - kk_block_decref(kk_datatype_as_ptr(d), ctx); - } - */ + kk_block_decref(kk_datatype_as_ptr(d,ctx), ctx); +} + +#define kk_datatype_from_base(b,ctx) (kk_datatype_from_ptr(&(b)->_block,ctx)) +#define kk_datatype_from_constructor(b,ctx) (kk_datatype_from_base(&(b)->_base,ctx)) +#define kk_datatype_as(tp,v,ctx) (kk_block_as(tp,kk_datatype_as_ptr(v,ctx))) +#define kk_datatype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_datatype_as_ptr(v,ctx),tag)) + + +static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { + kk_datatype_t d = { b.box }; + return d; } -#define kk_datatype_from_base(b) (kk_datatype_from_ptr(&(b)->_block)) -#define kk_datatype_from_constructor(b) (kk_datatype_from_base(&(b)->_base)) -#define kk_datatype_as(tp,v) (kk_block_as(tp,kk_datatype_as_ptr(v))) -#define kk_datatype_as_assert(tp,v,tag) (kk_block_assert(tp,kk_datatype_as_ptr(v),tag)) +static inline kk_box_t kk_datatype_box(kk_datatype_t d) { + kk_box_t b = { d.dbox }; + return b; +} +/* #define kk_define_static_datatype(decl,kk_struct_tp,name,tag) \ static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,tag) } }; \ decl kk_struct_tp* name = &_static_##name -#define kk_define_static_open_datatype(decl,kk_struct_tp,name,otag) /* ignore otag as it is initialized dynamically */ \ + // ignore otag as it is initialized dynamically +#define kk_define_static_open_datatype(decl,kk_struct_tp,name,otag) \ static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_OPEN) }, &kk__static_string_empty._base }; \ decl kk_struct_tp* name = &_static_##name +*/ + /*---------------------------------------------------------------------- @@ -1072,7 +1255,7 @@ typedef enum kk_unit_e { // Get a thread local unique number. static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { kk_integer_t u = ctx->unique; - ctx->unique = kk_integer_inc(kk_integer_dup(u),ctx); + ctx->unique = kk_integer_inc(kk_integer_dup(u,ctx),ctx); return u; } @@ -1121,12 +1304,12 @@ static inline bool kk_box_is_Nothing(kk_box_t b) { return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); } -static inline bool kk_box_is_Just(kk_box_t b) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b), KK_TAG_JUST)); +static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b,ctx), KK_TAG_JUST)); } -static inline bool kk_box_is_maybe(kk_box_t b) { - return (kk_box_is_Just(b) || kk_box_is_Nothing(b)); +static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_Just(b,ctx) || kk_box_is_Nothing(b)); } typedef struct kk_just_s { @@ -1138,7 +1321,7 @@ kk_decl_export kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ); static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { if (kk_box_is_ptr(b)) { - kk_block_t* bl = kk_ptr_unbox(b); + kk_block_t* bl = kk_ptr_unbox(b,ctx); if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { return kk_unbox_Just_block(bl,ctx); } @@ -1148,18 +1331,18 @@ static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { } static inline kk_box_t kk_box_Just( kk_box_t b, kk_context_t* ctx ) { - if kk_likely(!kk_box_is_maybe(b)) { + if kk_likely(!kk_box_is_maybe(b,ctx)) { return b; } else { kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); just->value = b; - return kk_basetype_box(just); + return kk_ptr_box(&just->_block,ctx); } } static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { - kk_assert_internal(!kk_box_is_maybe(b)); + kk_assert_internal(!kk_box_is_maybe(b,kk_get_context())); return kk_datatype_unbox(b); } @@ -1167,7 +1350,7 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { kk_unused(ctx); kk_assert_internal(!kk_datatype_has_singleton_tag(d,KK_TAG_NOTHING)); if (kk_datatype_is_ptr(d)) { - kk_block_t* b = kk_datatype_as_ptr(d); + kk_block_t* b = kk_datatype_as_ptr(d,ctx); if (kk_block_has_tag(b,KK_TAG_JUST)) { return kk_block_field(b,0); } @@ -1181,35 +1364,47 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { #define kk_function_as(tp,fun) kk_basetype_as_assert(tp,fun,KK_TAG_FUNCTION) #define kk_function_alloc_as(tp,scan_fsize,ctx) kk_block_alloc_as(tp,scan_fsize,KK_TAG_FUNCTION,ctx) -#define kk_function_call(restp,argtps,f,args) ((restp(*)argtps)(kk_cfun_ptr_unbox(f->fun)))args -#define kk_define_static_function(name,cfun,ctx) \ - static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, { ~KK_UP(0) } }; /* must be box_null */ \ - kk_function_t name = &_static_##name; \ - if (kk_box_eq(name->fun,kk_box_null)) { name->fun = kk_cfun_ptr_box((kk_cfun_ptr_t)&cfun,ctx); } // initialize on demand so it can be boxed properly +#define kk_function_call(restp,argtps,f,args,ctx) ((restp(*)argtps)(kk_kkfun_ptr_unbox(kk_basetype_as(struct kk_function_s*,f,ctx)->fun,ctx)))args +#if (KK_COMPRESS==0) +#define kk_define_static_function(name,cfun,ctx) \ + static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, kk_box_null_init }; /* must be box_null */ \ + struct kk_function_s* const _##name = &_static_##name; \ + kk_function_t name = { (intptr_t)_##name }; \ + if (kk_box_eq(_##name->fun,kk_box_null())) { _##name->fun = kk_kkfun_ptr_box(&cfun,ctx); } // initialize on demand we can encode the field */ +#else +// for a compressed heap, allocate static functions once in the heap on demand; these are never deallocated +#define kk_define_static_function(name,cfun,ctx) \ + static kk_function_t name = kk_basetype_null; \ + if (kk_basetype_is_null(name)) { \ + name = kk_basetype_alloc(struct kk_function_s, 1, ctx); \ + name->fun = kk_kkfun_ptr_box(&cfun, ctx); \ + } +#endif kk_function_t kk_function_id(kk_context_t* ctx); kk_function_t kk_function_null(kk_context_t* ctx); +bool kk_function_is_null(kk_function_t f, kk_context_t* ctx); -static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v) { - return kk_basetype_unbox_as_assert(kk_function_t, v, KK_TAG_FUNCTION); +static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v, kk_context_t* ctx) { + return kk_basetype_unbox_assert(v, KK_TAG_FUNCTION, ctx); } static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d) { return kk_basetype_box(d); } -static inline kk_decl_pure bool kk_function_is_unique(kk_function_t f) { - return kk_block_is_unique(&f->_block); +static inline kk_decl_pure bool kk_function_is_unique(kk_function_t f, kk_context_t* ctx) { + return kk_basetype_is_unique(f,ctx); } static inline void kk_function_drop(kk_function_t f, kk_context_t* ctx) { kk_basetype_drop_assert(f, KK_TAG_FUNCTION, ctx); } -static inline kk_function_t kk_function_dup(kk_function_t f) { - return kk_basetype_dup_assert(kk_function_t, f, KK_TAG_FUNCTION); +static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) { + return kk_basetype_dup_assert(f, KK_TAG_FUNCTION, ctx); } @@ -1228,12 +1423,12 @@ static inline kk_decl_const kk_vector_t kk_vector_empty(void) { return kk_datatype_from_tag((kk_tag_t)1); } -static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v) { +static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v, kk_context_t* ctx) { if (kk_datatype_is_singleton(v)) { return NULL; } else { - return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR); + return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR, ctx); } } @@ -1241,8 +1436,8 @@ static inline void kk_vector_drop(kk_vector_t v, kk_context_t* ctx) { kk_datatype_drop(v, ctx); } -static inline kk_vector_t kk_vector_dup(kk_vector_t v) { - return kk_datatype_dup(v); +static inline kk_vector_t kk_vector_dup(kk_vector_t v, kk_context_t* ctx) { + return kk_datatype_dup(v,ctx); } static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { @@ -1256,7 +1451,7 @@ static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** b length + 1, // +1 to include the kk_large_scan_fsize field itself KK_TAG_VECTOR, ctx); if (buf != NULL) *buf = &v->vec[0]; - return kk_datatype_from_base(&v->_base); + return kk_datatype_from_base(&v->_base,ctx); } } @@ -1270,8 +1465,8 @@ static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_co return v; } -static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len) { - kk_vector_large_t v = kk_vector_as_large_borrow(vd); +static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len, kk_context_t* ctx) { + kk_vector_large_t v = kk_vector_as_large_borrow(vd,ctx); if kk_unlikely(v==NULL) { if (len != NULL) *len = 0; return NULL; @@ -1286,21 +1481,21 @@ static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len) { } } -static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v) { +static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v, kk_context_t* ctx) { kk_ssize_t len; - kk_vector_buf_borrow(v, &len); + kk_vector_buf_borrow(v, &len, ctx); return len; } static inline kk_ssize_t kk_vector_len(const kk_vector_t v, kk_context_t* ctx) { - kk_ssize_t len = kk_vector_len_borrow(v); + kk_ssize_t len = kk_vector_len_borrow(v,ctx); kk_vector_drop(v, ctx); return len; } -static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i) { - kk_assert(i < kk_vector_len_borrow(v)); - kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL)[i]); +static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i, kk_context_t* ctx) { + kk_assert(i < kk_vector_len_borrow(v,ctx)); + kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL, ctx)[i],ctx); return res; } @@ -1319,14 +1514,15 @@ static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t /*-------------------------------------------------------------------------------------- References --------------------------------------------------------------------------------------*/ -typedef struct kk_ref_s { +struct kk_ref_s { kk_block_t _block; - _Atomic(uintptr_t) value; // kk_box_t -} *kk_ref_t; + _Atomic(kk_intb_t) value; +}; +typedef kk_basetype_t kk_ref_t; -kk_decl_export kk_box_t kk_ref_get_thread_shared(kk_ref_t r, kk_context_t* ctx); -kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(kk_ref_t r, kk_box_t value); -kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); +kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx); +kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value); +kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(struct kk_ref_s* r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { kk_unused(ctx); @@ -1335,29 +1531,30 @@ static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); - return kk_basetype_unbox_as_assert(kk_ref_t, b, KK_TAG_REF); + return kk_basetype_unbox_assert(b, KK_TAG_REF, ctx); } static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { kk_basetype_drop_assert(r, KK_TAG_REF, ctx); } -static inline kk_ref_t kk_ref_dup(kk_ref_t r) { - return kk_basetype_dup_assert(kk_ref_t, r, KK_TAG_REF); +static inline kk_ref_t kk_ref_dup(kk_ref_t r, kk_context_t* ctx) { + return kk_basetype_dup_assert(r, KK_TAG_REF, ctx); } static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { - kk_ref_t r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); + struct kk_ref_s* r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); kk_atomic_store_relaxed(&r->value,value.box); - return r; + return kk_basetype_from_base(r,ctx); } -static inline kk_box_t kk_ref_get(kk_ref_t r, kk_context_t* ctx) { +static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { + struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); - kk_box_dup(b); - kk_ref_drop(r,ctx); // TODO: make references borrowed (only get left) + kk_box_dup(b,ctx); + kk_block_drop(&r->_block,ctx); // TODO: make references borrowed (only get left) return b; } else { @@ -1366,7 +1563,8 @@ static inline kk_box_t kk_ref_get(kk_ref_t r, kk_context_t* ctx) { } } -static inline kk_box_t kk_ref_swap_borrow(kk_ref_t r, kk_box_t value) { +static inline kk_box_t kk_ref_swap_borrow(kk_ref_t _r, kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); @@ -1381,14 +1579,14 @@ static inline kk_box_t kk_ref_swap_borrow(kk_ref_t r, kk_box_t value) { static inline kk_unit_t kk_ref_set_borrow(kk_ref_t r, kk_box_t value, kk_context_t* ctx) { - kk_box_t b = kk_ref_swap_borrow(r, value); + kk_box_t b = kk_ref_swap_borrow(r, value, ctx); kk_box_drop(b, ctx); return kk_Unit; } // In Koka we can constrain the argument of f to be a local-scope reference. static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* ctx) { - return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx)); + return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx),ctx); } /*-------------------------------------------------------------------------------------- diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 141dc487c..72d37a55f 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -41,68 +41,69 @@ On 64-bit, We can encode half of the doubles as values by saving 1 bit; Possible ----------------------------------------------------------------*/ #if (KK_INTPTR_SIZE == 8) -#define KK_BOX_DOUBLE64 (1) // box doubles on 64-bit using strategy A1 by default +#define KK_BOX_DOUBLE64 (1) // box doubles on 64-bit using strategy A1 by default // #define KK_BOX_DOUBLE64 (2) // heap allocate negative doubles on 64-bit (strategy A2) // #define KK_BOX_DOUBLE64 (0) // heap allocate doubles interpreted as int64_t (strategy A0) #else #define KK_BOX_DOUBLE64 (0) #endif -#define KK_BOXED_VALUE_BITS (KK_INTF_BITS-1) // note: can be less than intptr_t on CHERI architectures for example - -#define KK_MAX_BOXED_INT ((kk_intf_t)KK_INTF_MAX >> (KK_INTF_BITS - KK_BOXED_VALUE_BITS)) -#define KK_MIN_BOXED_INT (- KK_MAX_BOXED_INT - 1) - -#define KK_MAX_BOXED_UINT ((kk_uintf_t)KK_UINTF_MAX >> (KK_INTF_BITS - KK_BOXED_VALUE_BITS)) -#define KK_MIN_BOXED_UINT (0) - // Forward declarations static inline bool kk_box_is_ptr(kk_box_t b); -static inline kk_block_t* kk_ptr_unbox(kk_box_t b); -static inline kk_box_t kk_ptr_box(const kk_block_t* p); +static inline kk_block_t* kk_ptr_unbox(kk_box_t b, kk_context_t* ctx); +static inline kk_box_t kk_ptr_box(const kk_block_t* p, kk_context_t* ctx); static inline kk_intf_t kk_intf_unbox(kk_box_t v); static inline kk_box_t kk_intf_box(kk_intf_t i); // Low level access -static inline kk_box_t _kk_box_new_ptr(const kk_block_t* p) { - kk_box_t b = { (uintptr_t)p }; +static inline kk_box_t kk_box_from_ptr(const kk_block_t* p, kk_context_t* ctx) { + kk_box_t b = { kk_ptr_encode((kk_ptr_t)p,ctx) }; return b; } -static inline kk_box_t _kk_box_new_value(kk_uintf_t u) { - kk_box_t b = { u }; + +static inline kk_box_t kk_box_from_value(kk_intf_t i, int extra_shift ) { + kk_box_t b = { kk_intf_encode(i,extra_shift) }; return b; } -static inline kk_uintf_t _kk_box_value(kk_box_t b) { - return (kk_uintf_t)(b.box); +static inline kk_ptr_t kk_box_to_ptr(kk_box_t b, kk_context_t* ctx) { + return kk_ptr_decode(b.box, ctx); } -static inline kk_ptr_t _kk_box_ptr(kk_box_t b) { - return (kk_ptr_t)(b.box); + +static inline kk_intf_t kk_box_to_value(kk_box_t b, int extra_shift) { + return kk_intf_decode(b.box, extra_shift); } + // query static inline bool kk_box_is_ptr(kk_box_t b) { - return ((_kk_box_value(b)&1)==0); + return kk_is_ptr(b.box); } + static inline bool kk_box_is_value(kk_box_t b) { - return ((_kk_box_value(b)&1)!=0); + return kk_is_value(b.box); } + // Are two boxed representations equal? static inline bool kk_box_eq(kk_box_t b1, kk_box_t b2) { return (b1.box == b2.box); } +// null initializer +#define kk_box_null_init (~KK_IP(0)) + // We cannot store NULL as a pointer (`kk_ptr_t`); use `box_null` instead -#define kk_box_null (_kk_box_new_ptr((kk_ptr_t)(~KK_UP(0)))) // -1 value +static inline kk_box_t kk_box_null(void) { + kk_box_t b = { kk_box_null_init }; + return b; +} -// null initializer -#define kk_box_null_init {~KK_UP(0)} static inline bool kk_box_is_null(kk_box_t b) { - return (b.box == kk_box_null.box); + return (b.box == kk_box_null_init); } static inline bool kk_box_is_non_null_ptr(kk_box_t v) { @@ -111,52 +112,53 @@ static inline bool kk_box_is_non_null_ptr(kk_box_t v) { } static inline bool kk_box_is_any(kk_box_t b) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b), KK_TAG_BOX_ANY)); + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b,kk_get_context()), KK_TAG_BOX_ANY)); } /*---------------------------------------------------------------- Box pointers and kk_intf_t ----------------------------------------------------------------*/ -static inline kk_ptr_t kk_ptr_unbox(kk_box_t v) { +static inline kk_ptr_t kk_ptr_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal(kk_box_is_ptr(v) || kk_box_is_any(v)); kk_assert_internal(v.box != 0); // no NULL pointers allowed - return _kk_box_ptr(v); + return kk_box_to_ptr(v, ctx); } -static inline kk_box_t kk_ptr_box(const kk_block_t* p) { +static inline kk_box_t kk_ptr_box(const kk_block_t* p, kk_context_t* ctx) { kk_assert_internal(((uintptr_t)p & 0x03) == 0); // check alignment kk_assert_internal(p != NULL); // block should never be NULL - return _kk_box_new_ptr(p); + return kk_box_from_ptr(p,ctx); } -static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { - kk_assert_internal(kk_box_is_value(b) || kk_box_is_any(b)); - return kk_shrf(_kk_box_value(b), 1); +static inline kk_intf_t kk_intf_unbox(kk_box_t v) { + kk_assert_internal(kk_box_is_value(v) || kk_box_is_any(v)); + return kk_box_to_value(v, 0); } -static inline kk_box_t kk_uintf_box(kk_uintf_t u) { - kk_assert_internal(u <= KK_MAX_BOXED_UINT); - return _kk_box_new_value((u << 1)|1); +static inline kk_box_t kk_intf_box(kk_intf_t i) { + return kk_box_from_value(i, 0); } -static inline kk_intf_t kk_intf_unbox(kk_box_t v) { - kk_assert_internal(kk_box_is_value(v) || kk_box_is_any(v)); - return kk_sarf((kk_intf_t)_kk_box_value(v), 1); // preserve sign + +static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { + kk_assert_internal(kk_box_is_value(b) || kk_box_is_any(b)); + return (kk_uintf_t)kk_intf_unbox(b); } -static inline kk_box_t kk_intf_box(kk_intf_t i) { - kk_assert_internal(i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT); - return _kk_box_new_value(((kk_uintf_t)i << 1)|1); +static inline kk_box_t kk_uintf_box(kk_uintf_t u) { + kk_assert_internal(u <= KK_INTF_BOX_MAX); + return kk_intf_box((kk_intf_t)u); } -static inline kk_box_t kk_box_dup(kk_box_t b) { - if (kk_box_is_ptr(b)) kk_block_dup(kk_ptr_unbox(b)); + +static inline kk_box_t kk_box_dup(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_ptr(b)) { kk_block_dup(kk_ptr_unbox(b, ctx)); } return b; } static inline void kk_box_drop(kk_box_t b, kk_context_t* ctx) { - if (kk_box_is_ptr(b)) kk_block_drop(kk_ptr_unbox(b), ctx); + if (kk_box_is_ptr(b)) { kk_block_drop(kk_ptr_unbox(b, ctx), ctx); } } /*---------------------------------------------------------------- @@ -169,24 +171,23 @@ kk_decl_export kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx); kk_decl_export kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx); kk_decl_export kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx); -#if (KK_INTPTR_SIZE <= 8) +#if (KK_INTF_SIZE <= 8) kk_decl_export int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx); kk_decl_export kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx); #else static inline int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { kk_unused(ctx); - intptr_t i = kk_sarp((intptr_t)v.box, 1); + kk_intf_t i = kk_intf_unbox(v, ctx); kk_assert_internal((i >= INT64_MIN && i <= INT64_MAX) || kk_box_is_any(v)); return (int64_t)i; } static inline kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { kk_unused(ctx); - kk_box_t b = { ((uintptr_t)i << 1) | 1 }; - return b; + return kk_intf_box(i); } #endif -#if (KK_INTPTR_SIZE<=4) +#if (KK_INTF_SIZE<=4) kk_decl_export int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx); kk_decl_export kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx); #else @@ -203,7 +204,7 @@ static inline kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE<=2) +#if (KK_INTF_SIZE<=2) kk_decl_export int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx); kk_decl_export kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx); #else @@ -219,7 +220,7 @@ static inline kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE == 8) && KK_BOX_DOUBLE64 +#if (KK_INTF_SIZE == 8) && KK_BOX_DOUBLE64 kk_decl_export kk_box_t kk_double_box(double d, kk_context_t* ctx); kk_decl_export double kk_double_unbox(kk_box_t b, kk_context_t* ctx); #else @@ -233,7 +234,7 @@ static inline kk_box_t kk_double_box(double d, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE == 4) +#if (KK_INTF_SIZE == 4) kk_decl_export float kk_float_unbox(kk_box_t b, kk_context_t* ctx); kk_decl_export kk_box_t kk_float_box(float f, kk_context_t* ctx); #else @@ -267,39 +268,23 @@ static inline size_t kk_size_unbox(kk_box_t b, kk_context_t* ctx) { return (size_t)kk_ssize_unbox(b, ctx); } -static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag ) { +static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag, kk_context_t* ctx ) { kk_unused_internal(kk_expected_tag); - kk_block_t* b = kk_ptr_unbox(v); + kk_block_t* b = kk_ptr_unbox(v,ctx); kk_assert_internal(kk_block_tag(b) == kk_expected_tag); return b; } -static inline kk_box_t kk_block_box(kk_block_t* b) { - return kk_ptr_box(b); +static inline kk_box_t kk_block_box(kk_block_t* b, kk_context_t* ctx) { + return kk_ptr_box(b, ctx); } -static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag) { +static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag, kk_context_t* ctx) { kk_unused_internal(tag); kk_assert_internal(kk_block_tag(b) == tag); - return kk_ptr_box(b); + return kk_ptr_box(b,ctx); } -#define kk_basetype_unbox_as_assert(tp,b,tag) (kk_block_assert(tp,kk_ptr_unbox(b),tag)) -#define kk_basetype_unbox_as(tp,b) ((tp)kk_ptr_unbox(b)) -#define kk_basetype_box(b) (kk_ptr_box(&(b)->_block)) - -#define kk_constructor_unbox_as(tp,b,tag) (kk_basetype_unbox_as_assert(tp,b,tag)) -#define kk_constructor_box(b) (kk_basetype_box(&(b)->_base)) - -static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { - kk_datatype_t d = { b.box }; - return d; -} - -static inline kk_box_t kk_datatype_box(kk_datatype_t d) { - kk_box_t b = { d.dbox }; - return b; -} static inline kk_uintx_t kk_enum_unbox(kk_box_t b) { return kk_uintf_unbox(b); @@ -355,7 +340,7 @@ typedef struct kk_boxed_value_s { // `box_any` is used to return when yielding // (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) static inline kk_box_t kk_box_any(kk_context_t* ctx) { - kk_basetype_dup_assert(kk_box_any_t, ctx->kk_box_any, KK_TAG_BOX_ANY); + kk_basetype_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); return kk_basetype_box(ctx->kk_box_any); } @@ -378,9 +363,9 @@ typedef struct kk_cptr_raw_s { } *kk_cptr_raw_t; kk_decl_export kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b); +kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx); kk_decl_export kk_box_t kk_cptr_box(void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_unbox(kk_box_t b); +kk_decl_export void* kk_cptr_unbox(kk_box_t b, kk_context_t* ctx); // C function pointers typedef void (*kk_cfun_ptr_t)(void); @@ -390,25 +375,36 @@ typedef struct kk_cfunptr_s { kk_cfun_ptr_t cfunptr; } *kk_cfunptr_t; -#define kk_cfun_ptr_box(f,ctx) kk_cfun_ptr_boxx((kk_cfun_ptr_t)f, ctx) +// kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx); -kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx); -// kk_decl_export kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b); -// inline as it is used for unboxing (higher-order) function pointers. -// if we can guarantee for those function addresses to be always aligned we -// can perhaps optimize this further (without needing a check)? -static inline kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b) { // never drop; only used from function call - if kk_likely(kk_box_is_value(b)) { - return (kk_cfun_ptr_t)(kk_uintf_unbox(b)); - } - else { - kk_cfunptr_t fp = kk_basetype_unbox_as_assert(kk_cfunptr_t, b, KK_TAG_CFUNPTR); - kk_cfun_ptr_t f = fp->cfunptr; - return f; - } +// Koka function pointers +// Best is if we can assume these are always aligned but that is difficult to ensure with various compilers. +// Instead we assume the top bit of a function address is always clear so we can encode as 2*address + 1. +// If the heap is compressed, use the offset to the main function +static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { // never drop; only used from function call + kk_unused(ctx); + intptr_t f = (intptr_t)fun; +#if KK_COMPRESS + f = f - (intptr_t)&kk_main_start; +#endif + kk_assert(kk_shrp(f, KK_INTPTR_BITS - 1) == 0); // assume top bit of function pointer addresses is clear + kk_assert(f >= KK_INTF_MIN && f <= KK_INTF_MAX); + kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value + return b; } +#define kk_kkfun_ptr_box(fun,ctx) kk_kkfun_ptr_boxx((kk_cfun_ptr_t)fun, ctx) + + +static inline kk_cfun_ptr_t kk_kkfun_ptr_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); + intptr_t f = kk_intf_decode(b.box, 0); +#if KK_COMPRESS + f = f + (intptr_t)&kk_main_start; +#endif + return (kk_cfun_ptr_t)f; +} #endif // include guard diff --git a/kklib/include/kklib/bytes.h b/kklib/include/kklib/bytes.h index f40d6c79c..1d0d05368 100644 --- a/kklib/include/kklib/bytes.h +++ b/kklib/include/kklib/bytes.h @@ -78,8 +78,8 @@ static inline void kk_bytes_drop(kk_bytes_t b, kk_context_t* ctx) { kk_datatype_drop(b, ctx); } -static inline kk_bytes_t kk_bytes_dup(kk_bytes_t b) { - return kk_datatype_dup(b); +static inline kk_bytes_t kk_bytes_dup(kk_bytes_t b, kk_context_t* ctx) { + return kk_datatype_dup(b,ctx); } @@ -117,19 +117,19 @@ static inline kk_bytes_t kk_bytes_alloc_raw_len(kk_ssize_t len, const uint8_t* p br->free = (free ? &kk_free_fun : NULL); br->cbuf = p; br->clength = len; - return kk_datatype_from_base(&br->_base); + return kk_datatype_from_base(&br->_base, ctx); } // Get access to the bytes via a pointer (and retrieve the length as well) -static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* len) { +static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* len, kk_context_t* ctx) { static const uint8_t empty[16] = { 0 }; if (kk_datatype_is_singleton(b)) { if (len != NULL) *len = 0; return empty; } - kk_tag_t tag = kk_datatype_tag(b); + kk_tag_t tag = kk_datatype_tag(b,ctx); if (tag == KK_TAG_BYTES_SMALL) { - const kk_bytes_small_t bs = kk_datatype_as_assert(kk_bytes_small_t, b, KK_TAG_BYTES_SMALL); + const kk_bytes_small_t bs = kk_datatype_as_assert(kk_bytes_small_t, b, KK_TAG_BYTES_SMALL, ctx); if (len != NULL) { // a small bytes of length N (<= 7) ends with an ending zero followed by (7 - N) trailing 0xFF bytes. #ifdef KK_ARCH_LITTLE_ENDIAN @@ -142,19 +142,19 @@ static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* return &bs->u.buf[0]; } else if (tag == KK_TAG_BYTES) { - kk_bytes_normal_t bn = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES); + kk_bytes_normal_t bn = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES, ctx); if (len != NULL) *len = bn->length; return &bn->buf[0]; } else { - kk_bytes_raw_t br = kk_datatype_as_assert(kk_bytes_raw_t, b, KK_TAG_BYTES_RAW); + kk_bytes_raw_t br = kk_datatype_as_assert(kk_bytes_raw_t, b, KK_TAG_BYTES_RAW, ctx); if (len != NULL) *len = br->clength; return br->cbuf; } } -static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* len) { - return (const char*)kk_bytes_buf_borrow(b, len); +static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* len, kk_context_t* ctx) { + return (const char*)kk_bytes_buf_borrow(b, len, ctx); } @@ -163,14 +163,14 @@ static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* l Length, compare --------------------------------------------------------------------------------------------------*/ -static inline kk_ssize_t kk_decl_pure kk_bytes_len_borrow(const kk_bytes_t b) { +static inline kk_ssize_t kk_decl_pure kk_bytes_len_borrow(const kk_bytes_t b, kk_context_t* ctx) { kk_ssize_t len; - kk_bytes_buf_borrow(b, &len); + kk_bytes_buf_borrow(b, &len, ctx); return len; } static inline kk_ssize_t kk_decl_pure kk_bytes_len(kk_bytes_t str, kk_context_t* ctx) { // bytes in UTF8 - kk_ssize_t len = kk_bytes_len_borrow(str); + kk_ssize_t len = kk_bytes_len_borrow(str,ctx); kk_bytes_drop(str,ctx); return len; } @@ -180,12 +180,12 @@ static inline bool kk_bytes_is_empty(kk_bytes_t s, kk_context_t* ctx) { } static inline kk_bytes_t kk_bytes_copy(kk_bytes_t b, kk_context_t* ctx) { - if (kk_datatype_is_singleton(b) || kk_datatype_is_unique(b)) { + if (kk_datatype_is_singleton(b) || kk_datatype_is_unique(b,ctx)) { return b; } else { kk_ssize_t len; - const uint8_t* buf = kk_bytes_buf_borrow(b, &len); + const uint8_t* buf = kk_bytes_buf_borrow(b, &len, ctx); kk_bytes_t bc = kk_bytes_alloc_dupn(len, buf, ctx); kk_bytes_drop(b, ctx); return bc; @@ -196,18 +196,18 @@ static inline bool kk_bytes_ptr_eq_borrow(kk_bytes_t b1, kk_bytes_t b2) { return (kk_datatype_eq(b1, b2)); } -static inline bool kk_bytes_is_empty_borrow(kk_bytes_t b) { - return (kk_bytes_len_borrow(b) == 0); +static inline bool kk_bytes_is_empty_borrow(kk_bytes_t b, kk_context_t* ctx) { + return (kk_bytes_len_borrow(b,ctx) == 0); } -kk_decl_export int kk_bytes_cmp_borrow(kk_bytes_t str1, kk_bytes_t str2); +kk_decl_export int kk_bytes_cmp_borrow(kk_bytes_t str1, kk_bytes_t str2, kk_context_t* ctx); kk_decl_export int kk_bytes_cmp(kk_bytes_t str1, kk_bytes_t str2, kk_context_t* ctx); -static inline bool kk_bytes_is_eq_borrow(kk_bytes_t s1, kk_bytes_t s2) { - return (kk_bytes_cmp_borrow(s1, s2) == 0); +static inline bool kk_bytes_is_eq_borrow(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { + return (kk_bytes_cmp_borrow(s1, s2,ctx) == 0); } -static inline bool kk_bytes_is_neq_borrow(kk_bytes_t s1, kk_bytes_t s2) { - return (kk_bytes_cmp_borrow(s1, s2) != 0); +static inline bool kk_bytes_is_neq_borrow(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { + return (kk_bytes_cmp_borrow(s1, s2, ctx) != 0); } static inline bool kk_bytes_is_eq(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { return (kk_bytes_cmp(s1, s2, ctx) == 0); diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 8f7f207ca..206360d3a 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -210,17 +210,17 @@ static inline bool kk_is_bigint(kk_integer_t i) { return !kk_is_smallint(i); } -static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { +static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i, kk_context_t* ctx) { kk_assert_internal(kk_is_bigint(i)); - #if KK_INT_TAG==1 - return (kk_ptr_t)(i.ibox); + #if KK_INT_TAG==KK_TAG_VALUE + return kk_ptr_decode(i.ibox,ctx); #else - return (kk_ptr_t)(i.ibox ^ 1); + return kk_ptr_decode(i.ibox^1, ctx); #endif } static inline kk_integer_t _kk_new_integer(kk_intf_t i) { - kk_integer_t z = { (uintptr_t)i }; // todo: optimize in case sizeof(kk_intf_t) < sizeof(intptr_t) ? + kk_integer_t z = { i }; return z; } @@ -236,7 +236,7 @@ static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for kno static inline bool kk_is_integer(kk_integer_t i) { return ((kk_is_smallint(i) && kk_smallint_from_integer(i) >= KK_SMALLINT_MIN && kk_smallint_from_integer(i) <= KK_SMALLINT_MAX) - || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i)) == KK_TAG_BIGINT)); + || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i,kk_get_context())) == KK_TAG_BIGINT)); } static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { @@ -336,16 +336,18 @@ static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { #if KK_INT_ARITHMETIC != KK_INT_USE_RENO // Isomorphic with boxed values -static inline kk_box_t kk_integer_box(kk_integer_t i) { - #if KK_INT_TAG == 1 +static inline kk_box_t kk_integer_box(kk_integer_t i, kk_context_t* ctx) { + kk_unused(ctx); + #if KK_INT_TAG == KK_TAG_VALUE kk_box_t b = { i.ibox }; #else kk_box_t b = { i.ibox ^ 1 }; #endif return b; } -static inline kk_integer_t kk_integer_unbox(kk_box_t b) { - #if KK_INT_TAG == 1 +static inline kk_integer_t kk_integer_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); + #if KK_INT_TAG == KK_TAG_VALUE kk_integer_t i = { b.box }; #else kk_integer_t i = { b.box ^ 1 }; @@ -353,11 +355,11 @@ static inline kk_integer_t kk_integer_unbox(kk_box_t b) { return i; } #else -static inline kk_box_t kk_integer_box(kk_integer_t i) { - return (kk_is_smallint(i) ? kk_intf_box(kk_smallint_from_integer(i)) : kk_ptr_box(_kk_integer_ptr(i))); +static inline kk_box_t kk_integer_box(kk_integer_t i, kk_context_t* ctx) { + return (kk_is_smallint(i) ? kk_intf_box(kk_smallint_from_integer(i)) : kk_ptr_box(_kk_integer_ptr(i),ctx)); } -static inline kk_integer_t kk_integer_unbox(kk_box_t b) { - return (kk_box_is_value(b) ? kk_integer_from_small(kk_intf_unbox(b)) : kk_integer_from_ptr(kk_ptr_unbox(b))); +static inline kk_integer_t kk_integer_unbox(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_value(b) ? kk_integer_from_small(kk_intf_unbox(b)) : kk_integer_from_ptr(kk_ptr_unbox(b,ctx))); } #endif @@ -370,13 +372,13 @@ static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { kk_unused(i); kk_unused(ctx); } #else -static inline kk_integer_t kk_integer_dup(kk_integer_t i) { - if kk_unlikely(kk_is_bigint(i)) { kk_block_dup(_kk_integer_ptr(i)); } +static inline kk_integer_t kk_integer_dup(kk_integer_t i, kk_context_t* ctx) { + if kk_unlikely(kk_is_bigint(i)) { kk_block_dup(_kk_integer_ptr(i,ctx)); } return i; } static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { - if kk_unlikely(kk_is_bigint(i)) { kk_block_drop(_kk_integer_ptr(i), ctx); } + if kk_unlikely(kk_is_bigint(i)) { kk_block_drop(_kk_integer_ptr(i,ctx), ctx); } } #endif @@ -413,7 +415,7 @@ kk_decl_export kk_decl_noinline kk_integer_t kk_integer_sqr_generic(kk_integer_ kk_decl_export kk_decl_noinline kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx); kk_decl_export kk_decl_noinline bool kk_integer_is_even_generic(kk_integer_t x, kk_context_t* ctx); -kk_decl_export kk_decl_noinline int kk_integer_signum_generic_bigint(kk_integer_t x); +kk_decl_export kk_decl_noinline int kk_integer_signum_generic_bigint(kk_integer_t x, kk_context_t* ctx); kk_decl_export kk_decl_noinline kk_integer_t kk_integer_ctz(kk_integer_t x, kk_context_t* ctx); // count trailing zero digits kk_decl_export kk_decl_noinline kk_integer_t kk_integer_count_digits(kk_integer_t x, kk_context_t* ctx); // count decimal digits @@ -978,7 +980,7 @@ static inline kk_integer_t kk_integer_neg(kk_integer_t x, kk_context_t* ctx) { static inline kk_integer_t kk_integer_abs(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) < 0 ? kk_integer_neg_small(x, ctx) : x); - return (kk_integer_signum_generic_bigint(x) < 0 ? kk_integer_neg_generic(x, ctx) : x); + return (kk_integer_signum_generic_bigint(x,ctx) < 0 ? kk_integer_neg_generic(x, ctx) : x); } static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -1060,19 +1062,19 @@ static inline bool kk_integer_is_odd(kk_integer_t x, kk_context_t* ctx) { return !kk_integer_is_even_generic(x, ctx); } -static inline int kk_integer_signum_borrow(kk_integer_t x) { +static inline int kk_integer_signum_borrow(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)>_kk_integer_value(kk_integer_zero)) - (_kk_integer_value(x)<0)); - return kk_integer_signum_generic_bigint(x); + return kk_integer_signum_generic_bigint(x,ctx); } -static inline bool kk_integer_is_pos_borrow(kk_integer_t x) { +static inline bool kk_integer_is_pos_borrow(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) > _kk_integer_value(kk_integer_zero)); - return (kk_integer_signum_generic_bigint(x) > 0); + return (kk_integer_signum_generic_bigint(x,ctx) > 0); } -static inline bool kk_integer_is_neg_borrow(kk_integer_t x) { +static inline bool kk_integer_is_neg_borrow(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x)<0); - return (kk_integer_signum_generic_bigint(x) < 0); + return (kk_integer_signum_generic_bigint(x,ctx) < 0); } static inline kk_integer_t kk_integer_max(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -1124,7 +1126,7 @@ static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ct #endif } else { - return kk_integer_clamp32_generic(kk_integer_dup(x), ctx); + return kk_integer_clamp32_generic(kk_integer_dup(x,ctx), ctx); } } @@ -1152,7 +1154,7 @@ static inline int64_t kk_integer_clamp64_borrow(kk_integer_t x, kk_context_t* ct #endif } else { - return kk_integer_clamp64_generic(kk_integer_dup(x), ctx); + return kk_integer_clamp64_generic(kk_integer_dup(x,ctx), ctx); } } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index d8783fecb..6bc5714a5 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -353,47 +353,103 @@ typedef unsigned kk_uintx_t; #endif #define KK_INTX_BITS (8*KK_INTX_SIZE) -// `sizeof(kk_intf_t)` is `min(sizeof(kk_intx_t),sizeof(size_t))` -#if (KK_INTX_SIZE > KK_SIZE_SIZE) + + +// We have |kk_intf_t| <= |kk_box_t| <= |intptr_t|. +// These are generally all the same size, on x64 they will all be 64-bit. +// But not always: +// - |kk_intf_t| can be smaller than |kk_box_t| if pointers are larger than natural ints (say x86 huge) +// - |kk_box_t| can be smaller than |intptr_t| if pointers are compressed. +// For example using a compressed heap with 32-bit pointers on a 64-bit system, or +// 64-bit addresses on a 128-bit CHERI system. +// +// The `kk_intf_t` represents the largest integer size that fits into `kk_box_t` (minus 1 bit) +// but not larger than the natural register size for integers. + +// a boxed value is by default the size of an `intptr_t`. +#if !defined(KK_INTB_SIZE) +#define KK_INTB_SIZE KK_INTPTR_SIZE +#endif +#define KK_INTB_BITS (8*KK_INTB_SIZE) + + +// define `kk_intb_t` (the integer that can hold a boxed value) +#if (KK_INTB_SIZE == KK_INTPTR_SIZE) +#define KK_COMPRESS 0 +typedef intptr_t kk_intb_t; +typedef uintptr_t kk_uintb_t; +#define KK_INTB_MAX INTPTR_MAX +#define KK_INTB_MIN INTPTR_MIN +#define KK_IB(i) KK_IP(i) +#define PRIdIB "zd" +#elif (KK_INTB_SIZE == 8 && KK_INTB_SIZE < KK_INTPTR_SIZE) +#define KK_COMPRESS 1 +typedef int64_t kk_intb_t; +typedef uint64_t kk_uintb_t; +#define KK_INTB_MAX INT64_MAX +#define KK_INTB_MIN INT64_MIN +#define KK_IB(i) KK_I64(i) +#define PRIdIB PRIdI64 +#elif (KK_INTB_SIZE == 4 && KK_INTB_SIZE < KK_INTPTR_SIZE) +#define KK_COMPRESS 1 +typedef int32_t kk_intb_t; +typedef uint32_t kk_uintb_t; +#define KK_INTB_MAX INT32_MAX +#define KK_INTB_MIN INT32_MIN +#define KK_IB(i) KK_I32(i) +#define PRIdIB PRIdI32 +#else +#error "the given platform boxed integer size is (currently) not supported" +#endif + +#if !defined(KK_BOX_PTR_SHIFT) +#define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - 1) +#endif + + +// Largest natural integer that fits into a boxed value +#if (KK_INTB_SIZE > KK_SIZE_SIZE) // ensure it fits the natural register size typedef kk_ssize_t kk_intf_t; typedef size_t kk_uintf_t; -#define KK_UF(i) KK_UZ(i) #define KK_IF(i) KK_IZ(i) #define KK_INTF_SIZE KK_SSIZE_SIZE #define KK_INTF_MAX KK_SSIZE_MAX #define KK_INTF_MIN KK_SSIZE_MIN -#define KK_UINTF_MAX SIZE_MAX #else -typedef kk_intx_t kk_intf_t; -typedef kk_uintx_t kk_uintf_t; -#define KK_UF(i ) KK_UX(i) -#define KK_IF(i) KK_IX(i) -#define KK_INTF_SIZE KK_INTX_SIZE -#define KK_INTF_MAX KK_INTX_MAX -#define KK_INTF_MIN KK_INTX_MIN -#define KK_UINTF_MAX KK_UINTX_MAX +typedef kk_intb_t kk_intf_t; +typedef kk_intb_t kk_uintf_t; +#define KK_IF(i) KK_IB(i) +#define KK_INTF_SIZE 8 +#define KK_INTF_MAX INT64_MAX +#define KK_INTF_MIN INT64_MIN +#define PRIdIF PRIdIB #endif #define KK_INTF_BITS (8*KK_INTF_SIZE) // Distinguish unsigned shift right and signed arithmetic shift right. // (Here we assume >> is arithmetic right shift). Avoid UB by always masking the shift. -static inline kk_intx_t kk_sar(kk_intx_t i, kk_intx_t shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_uintx_t kk_shr(kk_uintx_t u, kk_intx_t shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_sarf(kk_intf_t i, kk_intf_t shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } -static inline kk_uintf_t kk_shrf(kk_uintf_t u, kk_intf_t shift){ return (u >> (shift & (KK_INTF_BITS - 1))); } -static inline uintptr_t kk_shrp(uintptr_t u, kk_intx_t shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } -static inline int32_t kk_sar32(int32_t i, int32_t shift) { return (i >> (shift & 31)); } -static inline uint32_t kk_shr32(uint32_t u, int32_t shift) { return (u >> (shift & 31)); } -static inline int64_t kk_sar64(int64_t i, int64_t shift) { return (i >> (shift & 63)); } -static inline uint64_t kk_shr64(uint64_t u, int64_t shift) { return (u >> (shift & 63)); } +static inline kk_intx_t kk_sar(kk_intx_t i, int shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_uintx_t kk_shr(kk_uintx_t u, int shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_sarf(kk_intf_t i, int shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_uintf_t kk_shrf(kk_uintf_t u, int shift) { return (u >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_sarb(kk_intb_t i, int shift) { return (i >> (shift & (KK_INTB_BITS - 1))); } + +static inline uintptr_t kk_shrp(uintptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline intptr_t kk_sarp(intptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_sar32(int32_t i, int shift) { return (i >> (shift & 31)); } +static inline uint32_t kk_shr32(uint32_t u, int shift) { return (u >> (shift & 31)); } +static inline int64_t kk_sar64(int64_t i, int shift) { return (i >> (shift & 63)); } +static inline uint64_t kk_shr64(uint64_t u, int shift) { return (u >> (shift & 63)); } // Avoid UB by left shifting on unsigned integers (and masking the shift). -static inline kk_intx_t kk_shl(kk_intx_t i, kk_intx_t shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_shlf(kk_intf_t i, kk_intf_t shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } -static inline int32_t kk_shl32(int32_t i, int32_t shift) { return (int32_t) ((uint32_t)i << (shift & 31)); } -static inline int64_t kk_shl64(int64_t i, int64_t shift) { return (int64_t) ((uint64_t)i << (shift & 63)); } -static inline intptr_t kk_shlp(intptr_t i, intptr_t shift) { return (intptr_t) ((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } +static inline kk_intx_t kk_shl(kk_intx_t i, int shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_shlf(kk_intf_t i, int shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_shlb(kk_intb_t i, int shift) { return (kk_intb_t)((kk_uintb_t)i << (shift & (KK_INTB_BITS - 1))); } +static inline intptr_t kk_shlp(intptr_t i, int shift) { return (intptr_t)((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_shl32(int32_t i, int shift) { return (int32_t)((uint32_t)i << (shift & 31)); } +static inline int64_t kk_shl64(int64_t i, int shift) { return (int64_t)((uint64_t)i << (shift & 63)); } + // Architecture assumptions diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index 41e5fc2b0..184ba84fc 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -107,22 +107,34 @@ static inline kk_string_t kk_unsafe_bytes_as_string_unchecked(kk_bytes_t b) { } static inline kk_string_t kk_unsafe_bytes_as_string(kk_bytes_t b) { - kk_assert_internal(kk_datatype_tag(b) == KK_TAG_BOX_ANY || kk_utf8_is_valid(kk_bytes_cbuf_borrow(b, NULL))); + kk_assert_internal(kk_datatype_tag(b,kk_get_context()) == KK_TAG_BOX_ANY || kk_utf8_is_valid(kk_bytes_cbuf_borrow(b, NULL, kk_get_context()))); return kk_unsafe_bytes_as_string_unchecked(b); } -static inline kk_string_t kk_string_empty(void) { +static inline kk_string_t kk_string_empty() { return kk_unsafe_bytes_as_string( kk_bytes_empty() ); } // Define string literals +#if 0 #define kk_define_string_literal(decl,name,len,chars) \ static struct { struct kk_bytes_s _base; size_t length; char str[len+1]; } _static_##name = \ { { { KK_HEADER_STATIC(0,KK_TAG_STRING) } }, len, chars }; \ - decl kk_string_t name = { { (uintptr_t)&_static_##name._base._block } }; + decl kk_string_t name = { { (intptr_t)&_static_##name._base._block } }; +#else +#define kk_declare_string_literal(decl,name,len,chars) \ + static kk_ssize_t _static_len_##name = len; \ + static const char* _static_##name = chars; \ + decl kk_string_t name = { 0 }; -#define kk_define_string_literal_empty(decl,name) \ - decl kk_string_t name = { { (kk_block_t*)((uintptr_t)(5)) } }; +#define kk_init_string_literal(name,ctx) \ + if (name.bytes.dbox == 0) { name = kk_string_alloc_from_utf8n(_static_len_##name, _static_##name, ctx); } + +#define kk_define_string_literal(decl,name,len,chars,ctx) \ + kk_declare_string_literal(decl,name,len,chars) \ + kk_init_string_literal(name,ctx) + +#endif static inline kk_string_t kk_string_unbox(kk_box_t v) { return kk_unsafe_bytes_as_string( kk_bytes_unbox(v) ); @@ -136,8 +148,8 @@ static inline void kk_string_drop(kk_string_t str, kk_context_t* ctx) { kk_bytes_drop(str.bytes, ctx); } -static inline kk_string_t kk_string_dup(kk_string_t str) { - return kk_unsafe_bytes_as_string(kk_bytes_dup(str.bytes)); +static inline kk_string_t kk_string_dup(kk_string_t str, kk_context_t* ctx) { + return kk_unsafe_bytes_as_string(kk_bytes_dup(str.bytes,ctx)); } @@ -228,24 +240,24 @@ static inline kk_string_t kk_string_alloc_raw(const char* s, bool free, kk_conte return kk_string_alloc_raw_len(kk_sstrlen(s), s, free, ctx); } -static inline const uint8_t* kk_string_buf_borrow(const kk_string_t str, kk_ssize_t* len) { - return kk_bytes_buf_borrow(str.bytes, len); +static inline const uint8_t* kk_string_buf_borrow(const kk_string_t str, kk_ssize_t* len, kk_context_t* ctx) { + return kk_bytes_buf_borrow(str.bytes, len, ctx); } -static inline const char* kk_string_cbuf_borrow(const kk_string_t str, kk_ssize_t* len) { - return (const char*)kk_string_buf_borrow(str, len); +static inline const char* kk_string_cbuf_borrow(const kk_string_t str, kk_ssize_t* len, kk_context_t* ctx) { + return (const char*)kk_string_buf_borrow(str, len, ctx); } -static inline int kk_string_cmp_cstr_borrow(const kk_string_t s, const char* t) { - return strcmp(kk_string_cbuf_borrow(s,NULL), t); +static inline int kk_string_cmp_cstr_borrow(const kk_string_t s, const char* t, kk_context_t* ctx) { + return strcmp(kk_string_cbuf_borrow(s,NULL,ctx), t); } -static inline kk_ssize_t kk_decl_pure kk_string_len_borrow(const kk_string_t str) { - return kk_bytes_len_borrow(str.bytes); +static inline kk_ssize_t kk_decl_pure kk_string_len_borrow(const kk_string_t str, kk_context_t* ctx) { + return kk_bytes_len_borrow(str.bytes,ctx); } static inline kk_ssize_t kk_decl_pure kk_string_len(kk_string_t str, kk_context_t* ctx) { // bytes in UTF8 - kk_ssize_t len = kk_string_len_borrow(str); + kk_ssize_t len = kk_string_len_borrow(str,ctx); kk_string_drop(str, ctx); return len; } @@ -258,8 +270,8 @@ static inline bool kk_string_ptr_eq_borrow(kk_string_t s1, kk_string_t s2) { return kk_bytes_ptr_eq_borrow(s1.bytes, s2.bytes); } -static inline bool kk_string_is_empty_borrow(kk_string_t s) { - return (kk_string_len_borrow(s) == 0); +static inline bool kk_string_is_empty_borrow(kk_string_t s, kk_context_t* ctx) { + return (kk_string_len_borrow(s,ctx) == 0); } static inline bool kk_string_is_empty(kk_string_t s, kk_context_t* ctx) { @@ -369,20 +381,20 @@ static inline kk_string_t kk_string_alloc_from_qutf16w(const wchar_t* wstr, k Utilities that can use the bytes functions --------------------------------------------------------------------------------------------------*/ -static inline int kk_string_cmp_borrow(kk_string_t str1, kk_string_t str2) { - return kk_bytes_cmp_borrow(str1.bytes, str2.bytes); +static inline int kk_string_cmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { + return kk_bytes_cmp_borrow(str1.bytes, str2.bytes,ctx); } static inline int kk_string_cmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { return kk_bytes_cmp(str1.bytes, str2.bytes, ctx); } -static inline bool kk_string_is_eq_borrow(kk_string_t s1, kk_string_t s2) { - return (kk_string_cmp_borrow(s1, s2) == 0); +static inline bool kk_string_is_eq_borrow(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { + return (kk_string_cmp_borrow(s1, s2, ctx) == 0); } -static inline bool kk_string_is_neq_borrow(kk_string_t s1, kk_string_t s2) { - return (kk_string_cmp_borrow(s1, s2) != 0); +static inline bool kk_string_is_neq_borrow(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { + return (kk_string_cmp_borrow(s1, s2, ctx) != 0); } static inline bool kk_string_is_eq(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { @@ -438,11 +450,11 @@ static inline bool kk_string_contains(kk_string_t str, kk_string_t sub, kk_con Utilities that are string specific --------------------------------------------------------------------------------------------------*/ -kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str); // number of code points +kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str, kk_context_t* ctx); // number of code points kk_decl_export kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx); // number of code points -kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern); +kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern, kk_context_t* ctx); -kk_decl_export int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2); // ascii case insensitive +kk_decl_export int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx); // ascii case insensitive kk_decl_export int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx); // ascii case insensitive diff --git a/kklib/src/box.c b/kklib/src/box.c index 32b275100..f1659eee9 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -23,8 +23,8 @@ intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { return (intptr_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INTPTR) || kk_box_is_any(v)); - boxed_intptr_t bi = kk_block_assert(boxed_intptr_t, kk_ptr_unbox(v), KK_TAG_INTPTR); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INTPTR) || kk_box_is_any(v)); + boxed_intptr_t bi = kk_block_assert(boxed_intptr_t, kk_ptr_unbox(v,ctx), KK_TAG_INTPTR); intptr_t i = bi->value; if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } return i; @@ -32,13 +32,13 @@ intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { return kk_intf_box(i); } else { boxed_intptr_t bi = kk_block_alloc_as(struct kk_boxed_intptr_s, 0, KK_TAG_INTPTR, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } @@ -55,8 +55,8 @@ int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { return (int64_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT64) || kk_box_is_any(v)); - boxed_int64_t bi = kk_block_assert(boxed_int64_t, kk_ptr_unbox(v), KK_TAG_INT64); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT64) || kk_box_is_any(v)); + boxed_int64_t bi = kk_block_assert(boxed_int64_t, kk_ptr_unbox(v,ctx), KK_TAG_INT64); int64_t i = bi->value; if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } return i; @@ -64,13 +64,13 @@ int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { return kk_intf_box((kk_intf_t)i); } else { boxed_int64_t bi = kk_block_alloc_as(struct kk_boxed_int64_s, 0, KK_TAG_INT64, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } #endif @@ -89,8 +89,8 @@ int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { return (int32_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT32) || kk_box_is_any(v)); - boxed_int32_t bi = kk_block_assert(boxed_int32_t, kk_ptr_unbox(v), KK_TAG_INT32); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT32) || kk_box_is_any(v)); + boxed_int32_t bi = kk_block_assert(boxed_int32_t, kk_ptr_unbox(v,ctx), KK_TAG_INT32); int32_t i = bi->value; if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } return i; @@ -98,7 +98,7 @@ int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { return kk_intf_box(i); } else { @@ -122,8 +122,8 @@ int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { return (int16_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT16) || kk_box_is_any(v)); - boxed_int16_t bi = kk_block_assert(boxed_int16_t, kk_ptr_unbox(v), KK_TAG_INT16); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT16) || kk_box_is_any(v)); + boxed_int16_t bi = kk_block_assert(boxed_int16_t, kk_ptr_unbox(v,ctx), KK_TAG_INT16); int16_t i = bi->value; if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } return i; @@ -131,7 +131,7 @@ int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { return kk_intf_box(i); } else { @@ -185,19 +185,19 @@ kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx) { kk_cptr_raw_t raw = kk_block_alloc_as(struct kk_cptr_raw_s, 0, KK_TAG_CPTR_RAW, ctx); raw->free = freefun; raw->cptr = p; - return kk_ptr_box(&raw->_block); + return kk_ptr_box(&raw->_block,ctx); } -void* kk_cptr_raw_unbox(kk_box_t b) { - kk_cptr_raw_t raw = kk_basetype_unbox_as_assert(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW); +void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx) { + kk_cptr_raw_t raw = kk_basetype_unbox_as_assert(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); return raw->cptr; } kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { - uintptr_t u = (uintptr_t)p; - if kk_likely((u&1) == 0 && u <= KK_MAX_BOXED_UINT) { // aligned pointer? + intptr_t i = (intptr_t)p; + if kk_likely(i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { // box as value - return _kk_box_new_value((kk_uintf_t)(u|1)); + return kk_intf_box((kk_intf_t)i); } else { // allocate @@ -205,27 +205,12 @@ kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { } } -void* kk_cptr_unbox(kk_box_t b) { +void* kk_cptr_unbox(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_value(b)) { - return (void*)(_kk_box_value(b) ^ 1); // clear lowest bit - } - else { - return kk_cptr_raw_unbox(b); - } -} - -// C Function pointers - -kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx) { - uintptr_t u = (uintptr_t)f; // assume we can convert a function pointer to uintptr_t... - if ((u <= KK_MAX_BOXED_UINT) && sizeof(u)==sizeof(f)) { // aligned pointer? (and sanity check if function pointer != object pointer) - return kk_uintf_box(u); + return (void*)((intptr_t)kk_intf_unbox(b)); } else { - // otherwise allocate - kk_cfunptr_t fp = kk_block_alloc_as(struct kk_cfunptr_s, 0, KK_TAG_CFUNPTR, ctx); - fp->cfunptr = f; - return kk_ptr_box(&fp->_block); + return kk_cptr_raw_unbox(b,ctx); } } @@ -237,15 +222,14 @@ kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx) { kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ) { kk_assert_internal(kk_block_has_tag(b,KK_TAG_JUST)); - kk_just_t* just = kk_block_as(kk_just_t*,b); - kk_box_t res = just->value; + kk_box_t res = kk_block_as(kk_just_t*, b)->value; if (ctx != NULL) { - if (kk_basetype_is_unique(just)) { - kk_basetype_free(just,ctx); + if (kk_block_is_unique(b)) { + kk_block_free(b,ctx); } else { - kk_box_dup(res); - kk_basetype_decref(just, ctx); + kk_box_dup(res,ctx); + kk_block_decref(b, ctx); } } return res; @@ -264,16 +248,16 @@ typedef struct kk_boxed_double_s { } *kk_boxed_double_t; static double kk_double_unbox_heap(kk_box_t b, kk_context_t* ctx) { - kk_boxed_double_t dt = kk_block_assert(kk_boxed_double_t, kk_ptr_unbox(b), KK_TAG_DOUBLE); + kk_boxed_double_t dt = kk_block_assert(kk_boxed_double_t, kk_ptr_unbox(b,ctx), KK_TAG_DOUBLE); double d = dt->value; - if (ctx != NULL) { kk_basetype_drop(dt, ctx); } + if (ctx != NULL) { kk_base_type_drop(dt, ctx); } return d; } static kk_box_t kk_double_box_heap(double d, kk_context_t* ctx) { kk_boxed_double_t dt = kk_block_alloc_as(struct kk_boxed_double_s, 0, KK_TAG_DOUBLE, ctx); dt->value = d; - return kk_ptr_box(&dt->_block); + return kk_ptr_box(&dt->_block, ctx); } @@ -329,7 +313,7 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { return kk_double_box_heap(d, ctx); } kk_assert_internal(exp <= 0x3FF); - kk_box_t b = { (u | (exp<<1) | 1) }; + kk_box_t b = { (intptr_t)_kk_make_value(u | (exp<<1)) }; return b; } @@ -376,16 +360,16 @@ typedef struct kk_boxed_float_s { } *kk_boxed_float_t; static float kk_float_unbox_heap(kk_box_t b, kk_context_t* ctx) { - kk_boxed_float_t ft = kk_block_assert(kk_boxed_float_t, kk_ptr_unbox(b), KK_TAG_FLOAT); + kk_boxed_float_t ft = kk_block_assert(kk_boxed_float_t, kk_ptr_unbox(b,ctx), KK_TAG_FLOAT); float f = ft->value; - if (ctx != NULL) { kk_basetype_drop(ft, ctx); } + if (ctx != NULL) { kk_base_type_drop(ft, ctx); } return f; } static kk_box_t kk_float_box_heap(float f, kk_context_t* ctx) { kk_boxed_float_t ft = kk_block_alloc_as(struct kk_boxed_float_s, 0, KK_TAG_FLOAT, ctx); ft->value = f; - return kk_ptr_box(&ft->_block); + return kk_ptr_box(&ft->_block,ctx); } kk_box_t kk_float_box(float f, kk_context_t* ctx) { diff --git a/kklib/src/bytes.c b/kklib/src/bytes.c index 2846973f5..f6c13f693 100644 --- a/kklib/src/bytes.c +++ b/kklib/src/bytes.c @@ -31,7 +31,7 @@ kk_decl_export kk_decl_noinline kk_bytes_t kk_bytes_alloc_len(kk_ssize_t len, kk } b->u.buf[len] = 0; if (buf != NULL) *buf = &b->u.buf[0]; - return kk_datatype_from_base(&b->_base); + return kk_datatype_from_base(&b->_base,ctx); } else { kk_bytes_normal_t b = kk_block_assert(kk_bytes_normal_t, kk_block_alloc_any(kk_ssizeof(struct kk_bytes_normal_s) - 1 /* char b[1] */ + len + 1 /* 0 terminator */, 0, KK_TAG_BYTES, ctx), KK_TAG_BYTES); @@ -42,7 +42,7 @@ kk_decl_export kk_decl_noinline kk_bytes_t kk_bytes_alloc_len(kk_ssize_t len, kk b->buf[len] = 0; if (buf != NULL) *buf = &b->buf[0]; // todo: kk_assert valid utf-8 in debug mode - return kk_datatype_from_base(&b->_base); + return kk_datatype_from_base(&b->_base,ctx); } } @@ -53,15 +53,15 @@ kk_bytes_t kk_bytes_adjust_length(kk_bytes_t b, kk_ssize_t newlen, kk_context_t* return kk_bytes_empty(); } kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); if (len == newlen) { return b; } else if (len > newlen && (3*(len/4)) < newlen && // 0.75*len < newlen < len: update length in place if we can - kk_datatype_is_unique(b) && kk_datatype_has_tag(b, KK_TAG_BYTES)) { + kk_datatype_is_unique(b,ctx) && kk_datatype_has_tag(b, KK_TAG_BYTES, ctx)) { // length in place - kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES) && kk_datatype_is_unique(b)); - kk_bytes_normal_t nb = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES); + kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES,ctx) && kk_datatype_is_unique(b,ctx)); + kk_bytes_normal_t nb = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES, ctx); nb->length = newlen; nb->buf[newlen] = 0; // kk_assert_internal(kk_bytes_is_valid(kk_bytes_dup(s),ctx)); @@ -101,12 +101,12 @@ const uint8_t* kk_memmem(const uint8_t* p, kk_ssize_t plen, const uint8_t* pat, return NULL; } -int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2) { +int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { if (kk_bytes_ptr_eq_borrow(b1, b2)) return 0; kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1,ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_bytes_buf_borrow(b2,&len2); + const uint8_t* s2 = kk_bytes_buf_borrow(b2,&len2,ctx); kk_ssize_t minlen = (len1 <= len2 ? len1 : len2); int ord = kk_memcmp(s1, s2, minlen); if (ord == 0) { @@ -117,7 +117,7 @@ int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2) { } int kk_bytes_cmp(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { - int ord = kk_bytes_cmp_borrow(b1,b2); + int ord = kk_bytes_cmp_borrow(b1,b2,ctx); kk_bytes_drop(b1,ctx); kk_bytes_drop(b2,ctx); return ord; @@ -128,12 +128,12 @@ int kk_bytes_cmp(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { Utilities --------------------------------------------------------------------------------------------------*/ -kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t pattern) { +kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t pattern, kk_context_t* ctx) { kk_ssize_t patlen; - const uint8_t* pat = kk_bytes_buf_borrow(pattern,&patlen); + const uint8_t* pat = kk_bytes_buf_borrow(pattern,&patlen,ctx); kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); - if (patlen <= 0) return kk_bytes_len_borrow(b); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); + if (patlen <= 0) return kk_bytes_len_borrow(b,ctx); if (patlen > len) return 0; //todo: optimize by doing backward Boyer-Moore? or use forward Knuth-Morris-Pratt? @@ -151,9 +151,9 @@ kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t p kk_bytes_t kk_bytes_cat(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1, &len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1, &len1, ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_bytes_buf_borrow(b2, &len2); + const uint8_t* s2 = kk_bytes_buf_borrow(b2, &len2, ctx); uint8_t* p; kk_bytes_t t = kk_bytes_alloc_buf(len1 + len2, &p, ctx ); kk_memcpy(p, s1, len1); @@ -167,7 +167,7 @@ kk_bytes_t kk_bytes_cat(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { kk_bytes_t kk_bytes_cat_from_buf(kk_bytes_t b1, kk_ssize_t len2, const uint8_t* b2, kk_context_t* ctx) { if (b2 == NULL || len2 <= 0) return b1; kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1,ctx); uint8_t* p; kk_bytes_t t = kk_bytes_alloc_buf(len1 + len2, &p, ctx); kk_memcpy(p, s1, len1); @@ -185,10 +185,10 @@ kk_vector_t kk_bytes_splitv_atmost(kk_bytes_t b, kk_bytes_t sepb, kk_ssize_t n, { if (n < 1) n = 1; kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b, &len); + const uint8_t* s = kk_bytes_buf_borrow(b, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t seplen; - const uint8_t* sep = kk_bytes_buf_borrow(sepb, &seplen); + const uint8_t* sep = kk_bytes_buf_borrow(sepb, &seplen, ctx); // count parts kk_ssize_t count = 1; @@ -235,19 +235,19 @@ kk_bytes_t kk_bytes_replace_all(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk_ssize_t n, kk_context_t* ctx) { kk_bytes_t t = s; - if (!(n<=0 || kk_bytes_is_empty_borrow(s) || kk_bytes_is_empty_borrow(pat))) + if (!(n<=0 || kk_bytes_is_empty_borrow(s, ctx) || kk_bytes_is_empty_borrow(pat, ctx))) { kk_ssize_t plen; - const uint8_t* p = kk_bytes_buf_borrow(s,&plen); + const uint8_t* p = kk_bytes_buf_borrow(s,&plen,ctx); kk_ssize_t ppat_len; - const uint8_t* ppat = kk_bytes_buf_borrow(pat,&ppat_len); + const uint8_t* ppat = kk_bytes_buf_borrow(pat,&ppat_len,ctx); kk_ssize_t prep_len; - const uint8_t* prep = kk_bytes_buf_borrow(rep, &prep_len); + const uint8_t* prep = kk_bytes_buf_borrow(rep, &prep_len,ctx); const uint8_t* const pend = p + plen; // if unique s && |rep| == |pat|, update in-place // TODO: if unique s & |rep| <= |pat|, maybe update in-place if not too much waste? - if (kk_datatype_is_unique(s) && ppat_len == prep_len) { + if (kk_datatype_is_unique(s,ctx) && ppat_len == prep_len) { kk_ssize_t count = 0; while (count < n && p < pend) { const uint8_t* r = kk_memmem(p, pend - p, ppat, ppat_len); @@ -283,7 +283,7 @@ kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, } kk_ssize_t rest = (pend - p); kk_memcpy(q, p, rest); - kk_assert_internal(q + rest == kk_bytes_buf_borrow(t,NULL) + newlen); + kk_assert_internal(q + rest == kk_bytes_buf_borrow(t,NULL,ctx) + newlen); } } @@ -297,7 +297,7 @@ kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk_bytes_t kk_bytes_repeat(kk_bytes_t b, kk_ssize_t n, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); if (len <= 0 || n<=0) return kk_bytes_empty(); uint8_t* t; kk_bytes_t tb = kk_bytes_alloc_buf(len*n, &t, ctx); // TODO: check overflow @@ -319,9 +319,9 @@ kk_bytes_t kk_bytes_repeat(kk_bytes_t b, kk_ssize_t n, kk_context_t* ctx) { // to avoid casting to signed, return 0 for not found, or the index+1 kk_ssize_t kk_bytes_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen,ctx); kk_ssize_t idx; if (tlen <= 0) { idx = (slen <= 0 ? 0 : 1); @@ -340,9 +340,9 @@ kk_ssize_t kk_bytes_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen,ctx); kk_ssize_t idx; if (tlen <= 0) { idx = slen; @@ -351,7 +351,7 @@ kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* c idx = 0; } else if (tlen == slen) { - idx = (kk_bytes_cmp_borrow(b, sub) == 0 ? 1 : 0); + idx = (kk_bytes_cmp_borrow(b, sub,ctx) == 0 ? 1 : 0); } else { const uint8_t* p; @@ -367,9 +367,9 @@ kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* c bool kk_bytes_starts_with(kk_bytes_t b, kk_bytes_t pre, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(pre, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(pre, &tlen,ctx); bool starts; if (tlen <= 0) { starts = (slen > 0); @@ -387,9 +387,9 @@ bool kk_bytes_starts_with(kk_bytes_t b, kk_bytes_t pre, kk_context_t* ctx) { bool kk_bytes_ends_with(kk_bytes_t b, kk_bytes_t post, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen, ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(post, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(post, &tlen, ctx); bool ends; if (tlen <= 0) { ends = (slen > 0); diff --git a/kklib/src/init.c b/kklib/src/init.c index 9e70d632a..cfd7c4649 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -23,18 +23,24 @@ static kk_box_t _function_id(kk_function_t self, kk_box_t x, kk_context_t* ctx) } kk_function_t kk_function_id(kk_context_t* ctx) { kk_define_static_function(fun_id, _function_id, ctx) - return kk_function_dup(fun_id); + return kk_function_dup(fun_id,ctx); } // null function static kk_box_t _function_null(kk_function_t self, kk_context_t* ctx) { kk_function_drop(self, ctx); kk_fatal_error(EFAULT, "null function is called"); - return kk_box_null; + return kk_box_null(); } kk_function_t kk_function_null(kk_context_t* ctx) { kk_define_static_function(fun_null, _function_null, ctx) - return kk_function_dup(fun_null); + return kk_function_dup(fun_null,ctx); +} +bool kk_function_is_null(kk_function_t f, kk_context_t* ctx) { + kk_function_t fnull = kk_function_null(ctx); + bool eq = kk_basetype_eq(f, fnull); + kk_function_drop(fnull, ctx); + return eq; } @@ -55,8 +61,8 @@ void kk_free_fun(void* p, kk_block_t* b, kk_context_t* ctx) { kk_string_t kk_get_host(kk_context_t* ctx) { kk_unused(ctx); - kk_define_string_literal(static, host, 5, "libc") - return kk_string_dup(host); + kk_define_string_literal(static, host, 5, "libc", ctx); + return kk_string_dup(host,ctx); } /*-------------------------------------------------------------------------------------------------- @@ -186,6 +192,7 @@ static void kklib_init(void) { // The thread local context; usually passed explicitly for efficiency. static kk_decl_thread kk_context_t* context; +#define kk_assign_const(tp,field) ((tp*)&(field))[0] static struct { kk_block_t _block; kk_integer_t cfc; } kk_evv_empty_static = { { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UP(0))^0x02) /*==-1 smallint*/} @@ -200,7 +207,7 @@ kk_context_t* kk_get_context(void) { #ifdef KK_MIMALLOC mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); - ctx->heap = heap; + kk_assign_const(kk_heap_t,ctx->heap) = heap; #else ctx = (kk_context_t*)kk_zalloc(sizeof(kk_context_t),NULL); #endif @@ -208,8 +215,8 @@ kk_context_t* kk_get_context(void) { ctx->thread_id = (size_t)(&context); ctx->unique = kk_integer_one; context = ctx; - ctx->kk_box_any = kk_block_alloc_as(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); - ctx->kk_box_any->_unused = kk_integer_zero; + ctx->kk_box_any = kk_basetype_alloc(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); + kk_basetype_as(struct kk_box_any_s*,ctx->kk_box_any,ctx)->_unused = kk_integer_zero; // todo: register a thread_done function to release the context on thread terminatation. return ctx; } diff --git a/kklib/src/integer.c b/kklib/src/integer.c index 1c4eb1397..6e13ff139 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -187,10 +187,11 @@ static kk_ptr_t bigint_ptr_(kk_bigint_t* x) { return &x->_block; } -static kk_integer_t bigint_as_integer_(kk_bigint_t* x) { - uintptr_t p = (uintptr_t)bigint_ptr_(x); - kk_assert_internal((p&3) == 0); - kk_integer_t i = { p }; +static kk_integer_t bigint_as_integer_(kk_bigint_t* x, kk_context_t* ctx) { + kk_integer_t i = { kk_ptr_encode(bigint_ptr_(x), ctx) }; +#if KK_INT_TAG!=KK_TAG_VALUE + i.ibox = i.ibox ^ 1; +#endif return i; } @@ -198,12 +199,13 @@ static bool bigint_is_unique_(kk_bigint_t* x) { return kk_block_is_unique(bigint_ptr_(x)); } -static kk_bigint_t* dup_bigint(kk_bigint_t* x) { - return kk_basetype_dup_as(kk_bigint_t*, x); +static kk_bigint_t* dup_bigint(kk_bigint_t* x, kk_context_t* ctx) { + kk_unused(ctx); + return kk_block_assert(kk_bigint_t*, kk_block_dup(&x->_block), KK_TAG_BIGINT); } static void drop_bigint(kk_bigint_t* x, kk_context_t* ctx) { - kk_basetype_drop(x,ctx); + kk_block_drop_assert(&x->_block,KK_TAG_BIGINT,ctx); } @@ -330,7 +332,7 @@ static kk_integer_t integer_bigint(kk_bigint_t* x, kk_context_t* ctx) { return kk_integer_from_small(i); } else { - return bigint_as_integer_(x); + return bigint_as_integer_(x,ctx); } } @@ -389,7 +391,7 @@ static kk_bigint_t* bigint_from_uint64(uint64_t i, kk_context_t* ctx) { static kk_bigint_t* kk_integer_to_bigint(kk_integer_t x, kk_context_t* ctx) { kk_assert_internal(kk_is_integer(x)); if (kk_is_bigint(x)) { - return kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x), KK_TAG_BIGINT); + return kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x,ctx), KK_TAG_BIGINT); } else { kk_assert_internal(kk_is_smallint(x)); @@ -398,15 +400,15 @@ static kk_bigint_t* kk_integer_to_bigint(kk_integer_t x, kk_context_t* ctx) { } kk_integer_t kk_integer_from_bigu64(uint64_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_uint64(i, ctx)); + return bigint_as_integer_(bigint_from_uint64(i, ctx),ctx); } kk_integer_t kk_integer_from_big64(int64_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_int64(i,ctx)); + return bigint_as_integer_(bigint_from_int64(i,ctx),ctx); } kk_integer_t kk_integer_from_big(kk_intx_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_int(i, ctx)); + return bigint_as_integer_(bigint_from_int(i, ctx),ctx); } @@ -746,7 +748,7 @@ bool kk_integer_hex_parse(const char* s, kk_integer_t* res, kk_context_t* ctx) { static kk_bigint_t* bigint_neg(kk_bigint_t* x, kk_context_t* ctx) { kk_bigint_t* z = bigint_ensure_unique(x,ctx); - z->is_neg = !z->is_neg; + z->is_neg = (z->is_neg == 0); return z; } @@ -999,7 +1001,7 @@ static kk_bigint_t* kk_bigint_mul_small(kk_bigint_t* x, kk_digit_t y, kk_context } static kk_bigint_t* kk_bigint_sqr(kk_bigint_t* x, kk_context_t* ctx) { - dup_bigint(x); + dup_bigint(x,ctx); return bigint_mul(x, x, ctx); } @@ -1036,17 +1038,17 @@ static kk_bigint_t* bigint_mul_karatsuba(kk_bigint_t* x, kk_bigint_t* y, kk_cont if (n <= 25) return bigint_mul(x, y, ctx); n = ((n + 1) / 2); - kk_bigint_t* b = kk_bigint_slice(dup_bigint(x), n, x->count, ctx); + kk_bigint_t* b = kk_bigint_slice(dup_bigint(x,ctx), n, x->count, ctx); kk_bigint_t* a = kk_bigint_slice(x, 0, n, ctx); - kk_bigint_t* d = kk_bigint_slice(dup_bigint(y), n, y->count, ctx); + kk_bigint_t* d = kk_bigint_slice(dup_bigint(y, ctx), n, y->count, ctx); kk_bigint_t* c = kk_bigint_slice(y, 0, n, ctx); - kk_bigint_t* ac = bigint_mul_karatsuba(dup_bigint(a), dup_bigint(c), ctx); - kk_bigint_t* bd = bigint_mul_karatsuba(dup_bigint(b), dup_bigint(d), ctx); + kk_bigint_t* ac = bigint_mul_karatsuba(dup_bigint(a, ctx), dup_bigint(c, ctx), ctx); + kk_bigint_t* bd = bigint_mul_karatsuba(dup_bigint(b, ctx), dup_bigint(d, ctx), ctx); kk_bigint_t* abcd = bigint_mul_karatsuba( bigint_add(a, b, b->is_neg, ctx), bigint_add(c, d, d->is_neg, ctx), ctx); - kk_bigint_t* p1 = kk_bigint_shift_left(kk_bigint_sub(kk_bigint_sub(abcd, dup_bigint(ac), ac->is_neg, ctx), - dup_bigint(bd), bd->is_neg, ctx), n, ctx); + kk_bigint_t* p1 = kk_bigint_shift_left(kk_bigint_sub(kk_bigint_sub(abcd, dup_bigint(ac, ctx), ac->is_neg, ctx), + dup_bigint(bd, ctx), bd->is_neg, ctx), n, ctx); kk_bigint_t* p2 = kk_bigint_shift_left(bd, 2 * n, ctx); kk_bigint_t* prod = bigint_add(bigint_add(ac, p1, p1->is_neg, ctx), p2, p2->is_neg, ctx); return kk_bigint_trim(prod,true, ctx); @@ -1072,15 +1074,15 @@ kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { return (kk_integer_is_even(p,ctx) ? kk_integer_one : kk_integer_min_one); } } - if (kk_integer_signum_borrow(p)==-1) { + if (kk_integer_signum_borrow(p,ctx)==-1) { kk_integer_drop(p,ctx); return kk_integer_zero; } kk_integer_t y = kk_integer_one; if (kk_is_bigint(p)) { while (1) { - kk_integer_dup(p); + kk_integer_dup(p, ctx); if (kk_integer_is_odd(p,ctx)) { - kk_integer_dup(x); + kk_integer_dup(x, ctx); y = kk_integer_mul(y, x, ctx); p = kk_integer_dec(p, ctx); } @@ -1093,7 +1095,7 @@ kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { kk_intx_t i = kk_smallint_from_integer(p); while (1) { if ((i&1)!=0) { - kk_integer_dup(x); + kk_integer_dup(x, ctx); y = kk_integer_mul(y, x, ctx); i--; } @@ -1259,9 +1261,9 @@ kk_integer_t kk_integer_sqr_generic(kk_integer_t x, kk_context_t* ctx) { } /* borrow x, may produce an invalid read if x is not a bigint */ -int kk_integer_signum_generic_bigint(kk_integer_t x) { +int kk_integer_signum_generic_bigint(kk_integer_t x, kk_context_t* ctx) { kk_assert_internal(kk_is_integer(x)); - kk_bigint_t* bx = kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x), KK_TAG_BIGINT); + kk_bigint_t* bx = kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x, ctx), KK_TAG_BIGINT); int signum = (bx->is_neg ? -1 : ((bx->count==0 && bx->digits[0]==0) ? 0 : 1)); return signum; } @@ -1285,7 +1287,7 @@ int kk_integer_cmp_generic(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { } int kk_integer_cmp_generic_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - return kk_integer_cmp_generic(kk_integer_dup(x), kk_integer_dup(y), ctx); + return kk_integer_cmp_generic(kk_integer_dup(x, ctx), kk_integer_dup(y, ctx), ctx); } kk_integer_t kk_integer_add_generic(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -1410,25 +1412,25 @@ kk_integer_t kk_integer_div_mod_generic(kk_integer_t x, kk_integer_t y, kk_integ kk_integer_drop(y, ctx); return kk_integer_zero; } - else if (kk_integer_is_pos_borrow(x)) { + else if (kk_integer_is_pos_borrow(x,ctx)) { // positive x return kk_integer_cdiv_cmod_generic(x, y, mod, ctx); } else { // regular kk_integer_t m; - kk_integer_t d = kk_integer_cdiv_cmod_generic(x, kk_integer_dup(y), &m, ctx); - if (kk_integer_is_neg_borrow(m)) { - if (kk_integer_is_neg_borrow(y)) { + kk_integer_t d = kk_integer_cdiv_cmod_generic(x, kk_integer_dup(y, ctx), &m, ctx); + if (kk_integer_is_neg_borrow(m,ctx)) { + if (kk_integer_is_neg_borrow(y, ctx)) { d = kk_integer_inc(d, ctx); if (mod!=NULL) { - m = kk_integer_sub(m, kk_integer_dup(y), ctx); + m = kk_integer_sub(m, kk_integer_dup(y, ctx), ctx); } } else { d = kk_integer_dec(d, ctx); if (mod!=NULL) { - m = kk_integer_add(m, kk_integer_dup(y), ctx); + m = kk_integer_add(m, kk_integer_dup(y, ctx), ctx); } } } @@ -1538,7 +1540,7 @@ kk_decl_export kk_string_t kk_integer_to_hex_string(kk_integer_t x, bool use_cap void kk_integer_fprint(FILE* f, kk_integer_t x, kk_context_t* ctx) { kk_string_t s = kk_integer_to_string(x, ctx); - fprintf(f, "%s", kk_string_cbuf_borrow(s,NULL)); + fprintf(f, "%s", kk_string_cbuf_borrow(s,NULL,ctx)); kk_string_drop(s, ctx); } @@ -1720,7 +1722,7 @@ kk_integer_t kk_integer_cdiv_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* } kk_integer_t kk_integer_div_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { - bool xneg = kk_integer_is_neg_borrow(x); + bool xneg = kk_integer_is_neg_borrow(x, ctx); kk_integer_t d = kk_integer_cdiv_pow10(x, p, ctx); if (xneg) { d = kk_integer_dec(d, ctx); diff --git a/kklib/src/os.c b/kklib/src/os.c index aa7f60a7c..dc3918e47 100644 --- a/kklib/src/os.c +++ b/kklib/src/os.c @@ -227,7 +227,7 @@ kk_decl_export int kk_os_write_text_file(kk_string_t path, kk_string_t content, } err = 0; kk_ssize_t len; - const uint8_t* buf = kk_string_buf_borrow(content, &len); + const uint8_t* buf = kk_string_buf_borrow(content, &len, ctx); if (len > 0) { kk_ssize_t nwritten; err = kk_posix_write_retry(f, buf, len, &nwritten); @@ -552,18 +552,18 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, kk_ssize_t count = 0; kk_ssize_t len = 100; - kk_vector_t vec = kk_vector_alloc(len, kk_integer_box(kk_integer_zero), ctx); + kk_vector_t vec = kk_vector_alloc(len, kk_integer_box(kk_integer_zero,ctx), ctx); do { kk_string_t name = os_direntry_name(&entry, ctx); - if (!kk_string_is_empty_borrow(name)) { + if (!kk_string_is_empty_borrow(name,ctx)) { // push name if (count >= len) { // realloc vector const kk_ssize_t newlen = (len > 1000 ? len + 1000 : 2*len); - vec = kk_vector_realloc(vec, newlen, kk_integer_box(kk_integer_zero), ctx); + vec = kk_vector_realloc(vec, newlen, kk_integer_box(kk_integer_zero,ctx), ctx); len = newlen; } - (kk_vector_buf_borrow(vec, NULL))[count] = kk_string_box(name); + (kk_vector_buf_borrow(vec, NULL,ctx))[count] = kk_string_box(name); count++; } else { @@ -573,7 +573,7 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, os_findclose(d); if(count != len) { - *contents = kk_vector_realloc(vec, count, kk_box_null, ctx); + *contents = kk_vector_realloc(vec, count, kk_box_null(), ctx); } return err; } @@ -791,7 +791,7 @@ kk_string_t kk_os_realpath(kk_string_t path, kk_context_t* ctx) { DWORD res = GetFullPathNameW(wpath, 264, buf, NULL); if (res == 0) { // failure - rpath = kk_string_dup(path); + rpath = kk_string_dup(path,ctx); } else if (res >= 264) { DWORD pbuflen = res; @@ -799,7 +799,7 @@ kk_string_t kk_os_realpath(kk_string_t path, kk_context_t* ctx) { res = GetFullPathNameW(wpath, pbuflen, pbuf, NULL); if (res == 0 || res >= pbuflen) { // failed again - rpath = kk_string_dup(path); + rpath = kk_string_dup(path,ctx); } else { rpath = kk_string_alloc_from_qutf16w(pbuf, ctx); @@ -869,7 +869,7 @@ static kk_string_t kk_os_searchpathx(const char* paths, const char* fname, kk_co buf[plen+1+fnamelen] = 0; p = (r == pend ? r : r + 1); kk_string_t sfname = kk_string_alloc_from_qutf8(buf, ctx); - if (kk_os_is_file( kk_string_dup(sfname), ctx)) { + if (kk_os_is_file( kk_string_dup(sfname,ctx), ctx)) { s = kk_os_realpath(sfname,ctx); break; } @@ -910,7 +910,7 @@ static kk_string_t kk_os_app_path_generic(kk_context_t* ctx) { else { // basename, try to prefix with all entries in PATH kk_string_t s = kk_os_searchpathx(getenv("PATH"), p, ctx); - if (kk_string_is_empty_borrow(s)) s = kk_os_realpath(kk_string_alloc_from_qutf8(p,ctx),ctx); + if (kk_string_is_empty_borrow(s, ctx)) { s = kk_os_realpath(kk_string_alloc_from_qutf8(p, ctx), ctx); } return s; } } diff --git a/kklib/src/ref.c b/kklib/src/ref.c index 5b7bac6c7..e8e9a8c5c 100644 --- a/kklib/src/ref.c +++ b/kklib/src/ref.c @@ -9,7 +9,7 @@ // Atomic path for mutable references -kk_decl_export kk_box_t kk_ref_get_thread_shared(kk_ref_t r, kk_context_t* ctx) { +kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx) { // careful: we cannot first read and then dup the read value as it may be // overwritten and _dropped_ by another thread in between. To avoid this // situation we first atomically swap with a guard value 0, then dup, and @@ -22,20 +22,20 @@ again: ; if (b.box == 0) { b.box = 1; } // expect any value but 0 } while (!kk_atomic_cas_weak_relaxed(&r->value, &b.box, 0)); // we got it, and hold the "locked" reference (`r->value == 0`) - kk_box_dup(b); + kk_box_dup(b,ctx); // and release our lock by writing back `b` - uintptr_t guard = 0; - while (!kk_atomic_cas_strong_relaxed(&r->value, &guard, b.box)) { + kk_intb_t guard = 0; + while (!kk_atomic_cas_strong_relaxed(&r->value, &guard, b.box)) { assert(false); // should never happen! as a last resort, restart the operation kk_box_drop(b,ctx); goto again; } - kk_ref_drop(r, ctx); + kk_block_drop(&r->_block, ctx); return b; } -kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(kk_ref_t r, kk_box_t value) { +kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value) { // atomically swap, but not if guarded with 0 (to not interfere with a `ref_get`) kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index b7f73b3b4..713d3e5be 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -239,7 +239,7 @@ static bool kk_block_decref_no_free(kk_block_t* b) { static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) { kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { - kk_block_t* child = kk_ptr_unbox(v); + kk_block_t* child = kk_ptr_unbox(v,ctx); if (kk_block_decref_no_free(child)) { uint8_t v_scan_fsize = child->header.scan_fsize; if (v_scan_fsize == 0) { // free leaf nodes directly and pretend it was not a ptr field @@ -328,7 +328,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t // go down into the child if (i < scan_fsize) { // save our progress to continue here later (when moving up along the parent chain) - kk_block_field_set(b, 0, _kk_box_new_ptr(parent)); // set parent (use low-level box as parent could be NULL) + kk_block_field_set(b, 0, kk_box_from_ptr(parent,ctx)); // set parent (use low-level box as parent could be NULL) kk_block_field_idx_set(b,i); parent = b; } @@ -349,7 +349,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t // move_up: if (parent != NULL) { b = parent; - parent = _kk_box_ptr( kk_block_field(parent, 0) ); // low-level unbox as it can be NULL + parent = kk_box_to_ptr( kk_block_field(parent, 0), ctx ); // low-level unbox as it can be NULL scan_fsize = b->header.scan_fsize; i = kk_block_field_idx(b); kk_assert_internal(i < scan_fsize); @@ -478,7 +478,7 @@ static inline kk_block_t* kk_block_field_should_mark(kk_block_t* b, kk_ssize_t f kk_unused(ctx); kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { - kk_block_t* child = kk_ptr_unbox(v); + kk_block_t* child = kk_ptr_unbox(v,ctx); if (!kk_block_is_thread_shared(child)) { if (child->header.scan_fsize == 0) { // mark leaf objects directly as shared @@ -642,7 +642,7 @@ static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context if (child != NULL) { // visit the child, but remember our state and link back to the parent // note: we cannot optimize for the last child as in freeing as we need to restore all parent fields - kk_block_field_set(b, i - 1, _kk_box_new_ptr(parent)); // low-level box as parent can be NULL + kk_block_field_set(b, i - 1, kk_box_from_ptr(parent,ctx)); // low-level box as parent can be NULL kk_block_mark_idx_set(b, i); parent = b; b = child; @@ -659,8 +659,8 @@ static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context i = kk_block_mark_idx(parent); scan_fsize = parent->header.scan_fsize; kk_assert_internal(i > 0 && i <= scan_fsize); - kk_block_t* pparent = _kk_box_ptr( kk_block_field(parent, i-1) ); // low-level unbox on parent - kk_block_field_set(parent, i-1, kk_ptr_box(b)); // restore original pointer + kk_block_t* pparent = kk_box_to_ptr( kk_block_field(parent, i-1), ctx ); // low-level unbox on parent + kk_block_field_set(parent, i-1, kk_ptr_box(b,ctx)); // restore original pointer b = parent; parent = pparent; kk_assert_internal(!kk_block_is_thread_shared(b)); @@ -685,14 +685,14 @@ kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ) { kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ) { if (kk_box_is_non_null_ptr(b)) { - kk_block_mark_shared( kk_ptr_unbox(b), ctx ); + kk_block_mark_shared( kk_ptr_unbox(b,ctx), ctx ); } } kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_non_null_ptr(b)) { - kk_block_mark_shared_recx(kk_ptr_unbox(b), ctx); + kk_block_mark_shared_recx(kk_ptr_unbox(b, ctx), ctx); } } @@ -705,7 +705,7 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { kk_block_t* c = (kk_block_t*)kk_malloc_copy(b,ctx); kk_block_refcount_set(c,0); for( kk_ssize_t i = 0; i < kk_block_scan_fsize(b); i++) { - kk_box_dup(kk_block_field(c, i)); + kk_box_dup(kk_block_field(c, i), ctx); } return c; } @@ -713,20 +713,20 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { #if !defined(KK_CTAIL_NO_CONTEXT_PATH) kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { - kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res))); - kk_box_t cres = kk_box_null; // copied result context - kk_box_t* next = NULL; // pointer to the context path field in the parent block + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res, ctx))); + kk_box_t cres = kk_box_null(); // copied result context + kk_box_t* next = NULL; // pointer to the context path field in the parent block for( kk_box_t cur = res; kk_box_is_ptr(cur); cur = *next ) { - kk_block_t* b = kk_ptr_unbox(cur); + kk_block_t* b = kk_ptr_unbox(cur, ctx); const kk_ssize_t field = kk_block_field_idx(b) - 1; kk_assert_internal(field >= 0); kk_block_t* c = kk_block_alloc_copy(b,ctx); if (next == NULL) { - cres = kk_ptr_box(c); + cres = kk_ptr_box(c, ctx); } else { kk_box_drop(*next,ctx); - *next = kk_ptr_box(c); + *next = kk_ptr_box(c, ctx); } next = kk_block_field_address(c,field); } diff --git a/kklib/src/string.c b/kklib/src/string.c index 395e75bc6..6715353fe 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -48,11 +48,11 @@ static kk_ssize_t kk_wcslen(const uint16_t* wstr) { } -int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2) { +int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { kk_ssize_t len1; - const uint8_t* s1 = kk_string_buf_borrow(str1, &len1); + const uint8_t* s1 = kk_string_buf_borrow(str1, &len1, ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_string_buf_borrow(str2, &len2); + const uint8_t* s2 = kk_string_buf_borrow(str2, &len2, ctx); kk_ssize_t minlen = (len1 <= len2 ? len1 : len2); int ord = kk_memicmp(s1, s2, minlen); if (ord == 0) { @@ -63,7 +63,7 @@ int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2) { } int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { - int ord = kk_string_icmp_borrow(str1, str2); + int ord = kk_string_icmp_borrow(str1, str2, ctx); kk_string_drop(str1, ctx); kk_string_drop(str2, ctx); return ord; @@ -71,9 +71,9 @@ int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { // Count code points in a valid utf-8 string. -kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str) { +kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_ssize_t cont = 0; // continuation character counts const uint8_t* t = s; // current position const uint8_t* end = t + len; @@ -110,7 +110,7 @@ kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str) { } kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx) { - kk_ssize_t count = kk_string_count_borrow(str); + kk_ssize_t count = kk_string_count_borrow(str,ctx); kk_string_drop(str, ctx); return count; } @@ -344,7 +344,7 @@ static kk_string_t kk_qutf8_convert_from_invalid(kk_ssize_t len, const uint8_t* t += tcount; } } - kk_assert_internal((t - kk_string_buf_borrow(tstr, NULL)) == vlen); + kk_assert_internal((t - kk_string_buf_borrow(tstr, NULL, ctx)) == vlen); return tstr; } @@ -384,7 +384,7 @@ kk_string_t kk_string_convert_from_qutf8(kk_bytes_t str, kk_context_t* ctx) { // to avoid reallocation (to accommodate invalid sequences), we first check if // it is already valid utf-8 which should be very common; in that case we return the bytes/string as-is. kk_ssize_t len; - const uint8_t* const s = kk_bytes_buf_borrow(str, &len); + const uint8_t* const s = kk_bytes_buf_borrow(str, &len, ctx); kk_ssize_t vlen; bool valid = kk_qutf8_validate(len, s, true, &vlen); if (valid) { @@ -403,7 +403,7 @@ kk_string_t kk_string_convert_from_qutf8(kk_bytes_t str, kk_context_t* ctx) { const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_context_t* ctx) { // to avoid allocation, we first check if none of the characters are in the raw range. kk_ssize_t len; - const uint8_t* const s = kk_string_buf_borrow(str, &len); + const uint8_t* const s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t extra_count = 0; const uint8_t* p = s; @@ -467,7 +467,7 @@ const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_con uint16_t* kk_string_to_qutf16_borrow(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* const s = kk_string_buf_borrow(str, &len); + const uint8_t* const s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; // count utf-16 length (in 16-bit units) @@ -652,7 +652,7 @@ kk_string_t kk_string_alloc_from_codepage(const uint8_t* bstr, const uint16_t* c kk_utf8_write(c, s, &count); s += count; } - kk_assert_internal(s == (kk_string_buf_borrow(str, NULL) + len) && *s == 0); + kk_assert_internal(s == (kk_string_buf_borrow(str, NULL, ctx) + len) && *s == 0); return str; } @@ -661,12 +661,12 @@ kk_string_t kk_string_alloc_from_codepage(const uint8_t* bstr, const uint16_t* c String utilities --------------------------------------------------------------------------------------------------*/ -kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern) { +kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern, kk_context_t* ctx) { kk_ssize_t patlen; - const uint8_t* pat = kk_string_buf_borrow(pattern, &patlen); + const uint8_t* pat = kk_string_buf_borrow(pattern, &patlen, ctx); kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); - if (patlen <= 0) return kk_string_count_borrow(str); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); + if (patlen <= 0) return kk_string_count_borrow(str,ctx); if (patlen > len) return 0; //todo: optimize by doing backward Boyer-Moore? or use forward Knuth-Morris-Pratt? @@ -692,7 +692,7 @@ kk_string_t kk_string_from_char(kk_char_t c, kk_context_t* ctx) { kk_string_t kk_string_from_chars(kk_vector_t v, kk_context_t* ctx) { kk_ssize_t n; - kk_box_t* cs = kk_vector_buf_borrow(v, &n); + kk_box_t* cs = kk_vector_buf_borrow(v, &n, ctx); kk_ssize_t len = 0; for (kk_ssize_t i = 0; i < n; i++) { len += kk_utf8_len(kk_char_unbox(cs[i], ctx)); @@ -704,23 +704,23 @@ kk_string_t kk_string_from_chars(kk_vector_t v, kk_context_t* ctx) { kk_utf8_write(kk_char_unbox(cs[i], ctx), p, &count); p += count; } - kk_assert_internal(kk_string_buf_borrow(s, NULL) + n == p); + kk_assert_internal(kk_string_buf_borrow(s, NULL, ctx) + n == p); kk_vector_drop(v, ctx); return s; } kk_vector_t kk_string_to_chars(kk_string_t s, kk_context_t* ctx) { - kk_ssize_t n = kk_string_count_borrow(s); + kk_ssize_t n = kk_string_count_borrow(s,ctx); kk_box_t* cs; kk_vector_t v = kk_vector_alloc_uninit(n, &cs, ctx); kk_ssize_t len; - const uint8_t* p = kk_string_buf_borrow(s, &len); + const uint8_t* p = kk_string_buf_borrow(s, &len, ctx); for (kk_ssize_t i = 0; i < n; i++) { kk_ssize_t count; cs[i] = kk_char_box(kk_utf8_read(p, &count), ctx); p += count; } - kk_assert_internal(p == kk_string_buf_borrow(s, NULL) + len); + kk_assert_internal(p == kk_string_buf_borrow(s, NULL, ctx) + len); kk_string_drop(s, ctx); return v; } @@ -733,10 +733,10 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz { if (n < 1) n = 1; kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t seplen; - const uint8_t* sep = kk_string_buf_borrow(sepstr, &seplen); + const uint8_t* sep = kk_string_buf_borrow(sepstr, &seplen, ctx); // count parts kk_ssize_t count = 1; @@ -748,7 +748,7 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz } } else if (n > 1) { - count = kk_string_count_borrow(str); // todo: or special count upto n? + count = kk_string_count_borrow(str,ctx); // todo: or special count upto n? if (count > n) count = n; } kk_assert_internal(count >= 1 && count <= n); @@ -785,17 +785,17 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz kk_string_t kk_string_to_upper(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_string_t tstr; - if (kk_datatype_is_unique(str.bytes)) { + if (kk_datatype_is_unique(str.bytes, ctx)) { tstr = str; // update in-place } else { - kk_string_dup(str); // multi-thread safe as we still reference str with s + kk_string_dup(str, ctx); // multi-thread safe as we still reference str with s tstr = kk_string_copy(str, ctx); kk_assert_internal(!kk_datatype_eq(str.bytes, tstr.bytes)); } - uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL); // t & s may alias! + uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL, ctx); // t & s may alias! for (kk_ssize_t i = 0; i < len; i++) { t[i] = kk_ascii_toupper(s[i]); } @@ -805,17 +805,17 @@ kk_string_t kk_string_to_upper(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_to_lower(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_string_t tstr; - if (kk_datatype_is_unique(str.bytes)) { + if (kk_datatype_is_unique(str.bytes, ctx)) { tstr = str; // update in-place } else { - kk_string_dup(str); // multi-thread safe as we still reference str with s + kk_string_dup(str, ctx); // multi-thread safe as we still reference str with s tstr = kk_string_copy(str, ctx); kk_assert_internal(!kk_datatype_eq(str.bytes, tstr.bytes)); } - uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL); // t & s may alias! + uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL, ctx); // t & s may alias! for (kk_ssize_t i = 0; i < len; i++) { t[i] = kk_ascii_tolower(s[i]); } @@ -825,7 +825,7 @@ kk_string_t kk_string_to_lower(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_trim_left(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* p = s; for (; *p != 0 && kk_ascii_iswhite(*p); p++) {} if (p == s) return str; // no trim needed @@ -837,7 +837,7 @@ kk_string_t kk_string_trim_left(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_trim_right(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* p = s + len - 1; for (; p >= s && kk_ascii_iswhite(*p); p--) {} const kk_ssize_t tlen = (p - s) + 1; @@ -853,27 +853,27 @@ kk_string_t kk_string_trim_right(kk_string_t str, kk_context_t* ctx) { kk_unit_t kk_println(kk_string_t s, kk_context_t* ctx) { // TODO: set locale to utf-8? - puts(kk_string_cbuf_borrow(s, NULL)); // todo: allow printing embedded 0 characters? + puts(kk_string_cbuf_borrow(s, NULL, ctx)); // todo: allow printing embedded 0 characters? kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_print(kk_string_t s, kk_context_t* ctx) { // TODO: set locale to utf-8? - fputs(kk_string_cbuf_borrow(s, NULL), stdout); // todo: allow printing embedded 0 characters? + fputs(kk_string_cbuf_borrow(s, NULL, ctx), stdout); // todo: allow printing embedded 0 characters? kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_trace(kk_string_t s, kk_context_t* ctx) { - fputs(kk_string_cbuf_borrow(s, NULL), stderr); // todo: allow printing embedded 0 characters? + fputs(kk_string_cbuf_borrow(s, NULL, ctx), stderr); // todo: allow printing embedded 0 characters? fputs("\n", stderr); kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_trace_any(kk_string_t s, kk_box_t x, kk_context_t* ctx) { - fprintf(stderr, "%s: ", kk_string_cbuf_borrow(s, NULL)); + fprintf(stderr, "%s: ", kk_string_cbuf_borrow(s, NULL, ctx)); kk_string_drop(s, ctx); kk_trace(kk_show_any(x, ctx), ctx); return kk_Unit; @@ -940,26 +940,26 @@ kk_string_t kk_show_any(kk_box_t b, kk_context_t* ctx) { snprintf(buf, 128, "value(%li)", (long)kk_intf_unbox(b)); return kk_string_alloc_dup_valid_utf8(buf, ctx); } - else if (b.box == kk_box_null.box) { + else if (b.box == kk_box_null().box) { return kk_string_alloc_dup_valid_utf8("null", ctx); } else if (b.box == 0) { return kk_string_alloc_dup_valid_utf8("ptr(NULL)", ctx); } else { - kk_block_t* p = kk_ptr_unbox(b); + kk_block_t* p = kk_ptr_unbox(b, ctx); kk_tag_t tag = kk_block_tag(p); if (tag == KK_TAG_BIGINT) { // todo: add tag - return kk_integer_to_string(kk_integer_unbox(b), ctx); + return kk_integer_to_string(kk_integer_unbox(b, ctx), ctx); } else if (tag == KK_TAG_STRING_SMALL || tag == KK_TAG_STRING || tag == KK_TAG_STRING_RAW) { // todo: add tag return kk_string_unbox(b); } else if (tag == KK_TAG_FUNCTION) { - kk_function_t fun = kk_block_assert(kk_function_t, p, KK_TAG_FUNCTION); - snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun))); + struct kk_function_s* fun = kk_block_assert(struct kk_function_s*, p, KK_TAG_FUNCTION); + snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun, ctx))); kk_box_drop(b, ctx); return kk_string_alloc_dup_valid_utf8(buf, ctx); } diff --git a/kklib/src/thread.c b/kklib/src/thread.c index 04ebf930b..51413e1da 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -185,10 +185,10 @@ static kk_task_t* kk_task_alloc( kk_function_t fun, kk_promise_t p, kk_context_t } static void kk_task_exec( kk_task_t* task, kk_context_t* ctx ) { - if (task->fun != NULL) { - kk_function_dup(task->fun); - kk_box_t res = kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),task->fun,(task->fun,ctx)); - kk_box_dup(task->promise); + if (!kk_function_is_null(task->fun,ctx)) { + kk_function_dup(task->fun,ctx); + kk_box_t res = kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),task->fun,(task->fun,ctx),ctx); + kk_box_dup(task->promise,ctx); kk_promise_set( task->promise, res, ctx ); } kk_task_free(task,ctx); @@ -244,7 +244,7 @@ static void kk_tasks_enqueue( kk_task_group_t* tg, kk_task_t* task, kk_context_t static kk_promise_t kk_task_group_schedule( kk_task_group_t* tg, kk_function_t fun, kk_context_t* ctx ) { kk_promise_t p = kk_promise_alloc(ctx); - kk_task_t* task = kk_task_alloc(fun, kk_box_dup(p), ctx); + kk_task_t* task = kk_task_alloc(fun, kk_box_dup(p,ctx), ctx); pthread_mutex_lock(&tg->tasks_lock); kk_tasks_enqueue(tg,task,ctx); pthread_mutex_unlock(&tg->tasks_lock); @@ -361,7 +361,7 @@ static void kk_task_group_init(void) { kk_promise_t kk_task_schedule( kk_function_t fun, kk_context_t* ctx ) { pthread_once( &task_group_once, &kk_task_group_init ); kk_assert(task_group != NULL); - kk_block_mark_shared( &fun->_block, ctx ); // mark everything reachable from the task as shared + kk_block_mark_shared( kk_basetype_as_ptr(fun,ctx), ctx); // mark everything reachable from the task as shared if (ctx->task_group == NULL) { ctx->task_group = task_group; // let main thread participate instead of blocking on a promise.get } @@ -400,7 +400,7 @@ static kk_promise_t kk_promise_alloc(kk_context_t* ctx) { static void kk_promise_set( kk_promise_t pr, kk_box_t r, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr); + promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,ctx); kk_box_mark_shared(r,ctx); pthread_mutex_lock(&p->lock); kk_box_drop(p->result,ctx); @@ -422,7 +422,7 @@ static bool kk_promise_available( kk_promise_t pr, kk_context_t* ctx ) { */ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr); + promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,ctx); pthread_mutex_lock(&p->lock); while (kk_box_is_any(p->result)) { // if part of a task group, run other tasks while waiting @@ -470,7 +470,7 @@ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { } } pthread_mutex_unlock(&p->lock); - const kk_box_t result = kk_box_dup( p->result ); + const kk_box_t result = kk_box_dup( p->result,ctx ); kk_box_drop(pr,ctx); return result; } @@ -521,9 +521,9 @@ kk_lvar_t kk_lvar_alloc(kk_box_t init, kk_context_t* ctx) { void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,ctx); pthread_mutex_lock(&lv->lock); - lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx)); + lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx),ctx); kk_box_mark_shared(lv->result,ctx); // todo: can we mark outside the mutex? pthread_mutex_unlock(&lv->lock); pthread_cond_signal(&lv->available); @@ -532,16 +532,16 @@ void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_box_t kk_lvar_get( kk_lvar_t lvar, kk_box_t bot, kk_function_t is_gte, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,ctx); kk_box_t result; pthread_mutex_lock(&lv->lock); while (true) { - kk_function_dup(is_gte); - kk_box_dup(lv->result); - kk_box_dup(bot); - int32_t done = kk_function_call(int32_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),is_gte,(is_gte,lv->result,bot,ctx)); + kk_function_dup(is_gte,ctx); + kk_box_dup(lv->result,ctx); + kk_box_dup(bot,ctx); + int32_t done = kk_function_call(int32_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),is_gte,(is_gte,lv->result,bot,ctx),ctx); if (done != 0) { - result = kk_box_dup(lv->result); + result = kk_box_dup(lv->result,ctx); break; } // if part of a task group, run other tasks while waiting diff --git a/kklib/src/vector.c b/kklib/src/vector.c index 199066381..ff7ae5ac8 100644 --- a/kklib/src/vector.c +++ b/kklib/src/vector.c @@ -14,10 +14,10 @@ void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx) { kk_assert_internal(start >= 0); kk_ssize_t length; - kk_box_t* v = kk_vector_buf_borrow(_v, &length); + kk_box_t* v = kk_vector_buf_borrow(_v, &length, ctx); // inline kk_box_dup and kk_box_drop for better performance if (kk_box_is_ptr(def)) { - kk_block_t* b = kk_ptr_unbox(def); + kk_block_t* b = kk_ptr_unbox(def, ctx); for (kk_ssize_t i = start; i < length; i++) { kk_block_dup(b); // todo: dup with `length` in one go? v[i] = def; @@ -33,12 +33,12 @@ void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_co kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx) { kk_ssize_t len; - kk_box_t* src = kk_vector_buf_borrow(vec, &len); + kk_box_t* src = kk_vector_buf_borrow(vec, &len, ctx); kk_box_t* dest; kk_vector_t vdest = kk_vector_alloc_uninit(newlen, &dest, ctx); const kk_ssize_t n = (len > newlen ? newlen : len); for (kk_ssize_t i = 0; i < n; i++) { - dest[i] = kk_box_dup(src[i]); + dest[i] = kk_box_dup(src[i], ctx); } kk_vector_init_borrow(vdest, n, def, ctx); // set extra entries to default value kk_vector_drop(vec, ctx); @@ -46,22 +46,23 @@ kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, } kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx) { - kk_ssize_t len = kk_vector_len_borrow(vec); - return kk_vector_realloc(vec, len, kk_box_null, ctx); + kk_ssize_t len = kk_vector_len_borrow(vec, ctx); + return kk_vector_realloc(vec, len, kk_box_null(), ctx); } -kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { +kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t _r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); kk_vector_t v = kk_vector_unbox(b, ctx); - if kk_unlikely(!kk_datatype_is_unique(v)) { + if kk_unlikely(!kk_datatype_is_unique(v,ctx)) { // the old v is dropped by kk_ref_set_borrow - v = kk_vector_copy(kk_vector_dup(v), ctx); - kk_ref_set_borrow(r, kk_vector_box(v, ctx), ctx); + v = kk_vector_copy(kk_vector_dup(v,ctx), ctx); + kk_ref_set_borrow(_r, kk_vector_box(v, ctx), ctx); } kk_ssize_t len; - kk_box_t* p = kk_vector_buf_borrow(v, &len); + kk_box_t* p = kk_vector_buf_borrow(v, &len, ctx); kk_ssize_t i = kk_integer_clamp_ssize_t_borrow(idx, ctx); kk_assert(i < len); kk_box_drop(p[i], ctx); diff --git a/kklib/test/main.c b/kklib/test/main.c index f1a50d9f2..f3c54d7eb 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -30,7 +30,7 @@ struct __data1_list_s { kk_block_t _block; }; -define_singleton( static, struct __data1_list_s, __data1_singleton_Nil, (kk_tag_t)0) +define_singleton(static, struct __data1_list_s, __data1_singleton_Nil, (kk_tag_t)0) struct __data1_Cons { struct __data1_list_s _inherit; @@ -48,18 +48,18 @@ static __data1__list __data1__new_Cons(kk_box_t x, __data1__list tail, kk_contex } static struct __data1_Cons* __data1__as_Cons(__data1__list x) { assert(__data1__is_Cons(x)); - return kk_basetype_as(struct __data1_Cons*, x); + return (struct __data1_Cons*)(&x->_block); } -static msecs_t test_timing(const char* msg, size_t loops, void (*fun)(kk_integer_t,kk_integer_t), kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { +static msecs_t test_timing(const char* msg, size_t loops, void (*fun)(kk_integer_t, kk_integer_t), kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_unused(msg); msecs_t start = _clock_start(); for (size_t i = 0; i < loops; i++) { - fun(kk_integer_dup(x),kk_integer_dup(y)); + fun(kk_integer_dup(x, ctx), kk_integer_dup(y, ctx)); } msecs_t end = _clock_end(start); - kk_integer_drop(x,ctx); - kk_integer_drop(y,ctx); + kk_integer_drop(x, ctx); + kk_integer_drop(y, ctx); //printf("test %s, %zu iterations: %6.3f s\n", msg, loops, (double)(end)/1000.0); return end; } @@ -78,11 +78,11 @@ static void testx(const char* name, iop* op, xop* opx, intptr_t i, intptr_t j, k kk_integer_t y = _kk_new_integer(j); intptr_t k = _kk_integer_value(op(x, y, ctx)); intptr_t expect = opx(i, j, ctx); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", i, name, j, k, (k==expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", i, name, j, k, (k == expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); } -static void testb(const char* name, iop* op, kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx ) { +static void testb(const char* name, iop* op, kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { kk_integer_t k = (op(x, y, ctx)); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", _kk_integer_value(x), name, _kk_integer_value(y), _kk_integer_value(k), (_kk_integer_value(k)==_kk_integer_value(expect) ? "ok" : "FAIL"), _kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", _kk_integer_value(x), name, _kk_integer_value(y), _kk_integer_value(k), (_kk_integer_value(k) == _kk_integer_value(expect) ? "ok" : "FAIL"), _kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); } static void test_op(const char* name, iop* op, xop* opx, kk_context_t* ctx) { testx(name, op, opx, KK_SMALLINT_MAX, 1, ctx); @@ -113,7 +113,7 @@ static void test(kk_context_t* ctx) { } static void test_add(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); kk_integer_print(x, ctx); printf(" + "); kk_integer_print(y, ctx); printf(" = "); kk_integer_t z = kk_integer_add(x, y, ctx); kk_integer_print(z, ctx); printf(", expected: "); @@ -122,7 +122,7 @@ static void test_add(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_con } static void test_sub(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); kk_integer_print(x, ctx); printf(" - "); kk_integer_print(y, ctx); printf(" = "); kk_integer_t z = kk_integer_sub(x, y, ctx); kk_integer_print(z, ctx); printf(", expected: "); @@ -143,7 +143,7 @@ static void fibx(int n, kk_integer_t* x1, kk_integer_t* x2, kk_context_t* ctx) { kk_integer_t y1; kk_integer_t y2; fibx(n - 1, &y1, &y2, ctx); - *x2 = y1; kk_integer_dup(y1); + *x2 = y1; kk_integer_dup(y1, ctx); *x1 = kk_integer_add(y1, y2, ctx); } } @@ -151,7 +151,7 @@ static void fibx(int n, kk_integer_t* x1, kk_integer_t* x2, kk_context_t* ctx) { static kk_integer_t fib(int n, kk_context_t* ctx) { kk_integer_t y1; kk_integer_t y2; - fibx(n+1, &y1, &y2, ctx); + fibx(n + 1, &y1, &y2, ctx); kk_integer_drop(y2, ctx); return y1; } @@ -160,23 +160,23 @@ static kk_integer_t fib(int n, kk_context_t* ctx) { static void test_fib(int i, kk_context_t* ctx) { printf("fib %i = ", i); - kk_integer_print(fib(i,ctx), ctx); + kk_integer_print(fib(i, ctx), ctx); printf("\n"); } static void test_read(const char* s, kk_context_t* ctx) { printf("read %s = ", s); - kk_integer_print(kk_integer_from_str(s,ctx), ctx); + kk_integer_print(kk_integer_from_str(s, ctx), ctx); printf("\n"); } static void expect(bool b, bool exp) { kk_unused_release(b); kk_unused_release(exp); - assert(b==exp); + assert(b == exp); } static void expect_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); printf(" "); kk_integer_print(x, ctx); printf(" == "); kk_integer_print(y, ctx); bool eq = kk_integer_eq(x, y, ctx); printf(" %s\n", (eq ? "ok" : "FAIL")); @@ -189,36 +189,36 @@ static void test_cmp_pos(kk_context_t* ctx) { expect(kk_integer_gt(kk_integer_from_small(54), kk_integer_from_small(45), ctx), true); expect(kk_integer_gt(kk_integer_from_small(45), kk_integer_from_small(54), ctx), false); expect(kk_integer_gt(kk_integer_from_small(45), kk_integer_from_small(45), ctx), false); - expect(kk_integer_gt(kk_integer_from_str("5498765432109876",ctx), kk_integer_from_str("4598765432109876",ctx), ctx), true); - expect(kk_integer_gt(kk_integer_from_str("4598765432109876",ctx), kk_integer_from_str("5498765432109876",ctx), ctx),false); - expect(kk_integer_gt(kk_integer_from_str("4598765432109876",ctx), kk_integer_from_str("4598765432109876",ctx), ctx),false); + expect(kk_integer_gt(kk_integer_from_str("5498765432109876", ctx), kk_integer_from_str("4598765432109876", ctx), ctx), true); + expect(kk_integer_gt(kk_integer_from_str("4598765432109876", ctx), kk_integer_from_str("5498765432109876", ctx), ctx), false); + expect(kk_integer_gt(kk_integer_from_str("4598765432109876", ctx), kk_integer_from_str("4598765432109876", ctx), ctx), false); } static void test_addx(kk_context_t* ctx) { printf("addition\n"); - expect_eq(kk_integer_add(kk_integer_from_small(0),kk_integer_from_str("9844190321790980841789",ctx), ctx),kk_integer_from_str("9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9844190321790980841789",ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("-9844190321790980841789",ctx), ctx), kk_integer_from_str("-9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9844190321790980841789",ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("-9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983",ctx), kk_integer_from_str("-9999999999999998",ctx), ctx), kk_integer_from_str("-19007199254740981",ctx),ctx); - - expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - - expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); + expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("9844190321790980841789", ctx), ctx), kk_integer_from_str("9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9844190321790980841789", ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("-9844190321790980841789", ctx), ctx), kk_integer_from_str("-9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9844190321790980841789", ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("-9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983", ctx), kk_integer_from_str("-9999999999999998", ctx), ctx), kk_integer_from_str("-19007199254740981", ctx), ctx); + + expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + + expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); } #define append10(s) s s s s s s s s s s @@ -238,41 +238,41 @@ static void test_carry(kk_context_t* ctx) { kk_integer_t last = kk_integer_from_small(1); for (intptr_t i = 2; i < 99; i++) { - kk_integer_dup(last); + kk_integer_dup(last, ctx); num = kk_integer_add(num, last, ctx); - kk_integer_dup(num); + kk_integer_dup(num, ctx); last = kk_integer_sub(num, last, ctx); - kk_integer_dup(num); - expect_eq(num,kk_integer_from_str(fibs[i], ctx),ctx); + kk_integer_dup(num, ctx); + expect_eq(num, kk_integer_from_str(fibs[i], ctx), ctx); } kk_integer_drop(num, ctx); kk_integer_drop(last, ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9007199254740991",ctx),kk_integer_from_small(1), ctx), kk_integer_from_str("9007199254740992",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("999999999999999999999000000000000000000000",ctx),kk_integer_from_str("1000000000000000000000",ctx), ctx),kk_integer_from_str("1e42",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("1e20",ctx), kk_integer_from_str("9007199254740972",ctx), ctx), kk_integer_from_str("100009007199254740972",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983",ctx), kk_integer_from_str("-9999999999999998",ctx), ctx), kk_integer_from_str("-19007199254740981",ctx),ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9007199254740991", ctx), kk_integer_from_small(1), ctx), kk_integer_from_str("9007199254740992", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("999999999999999999999000000000000000000000", ctx), kk_integer_from_str("1000000000000000000000", ctx), ctx), kk_integer_from_str("1e42", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("1e20", ctx), kk_integer_from_str("9007199254740972", ctx), ctx), kk_integer_from_str("100009007199254740972", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983", ctx), kk_integer_from_str("-9999999999999998", ctx), ctx), kk_integer_from_str("-19007199254740981", ctx), ctx); - expect_eq(kk_integer_sub(kk_integer_from_str(c, ctx), kk_integer_add(kk_integer_from_str(b, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678899999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str(b, ctx), kk_integer_add(kk_integer_from_str(c, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678900000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("100000000000000000000000000000000000",ctx),kk_integer_from_str("999999999999999999",ctx), ctx), kk_integer_from_str("99999999999999999000000000000000001",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("10000000010000000",ctx), kk_integer_from_str("10000000",ctx), ctx), kk_integer_from_str("10000000000000000",ctx),ctx); + expect_eq(kk_integer_sub(kk_integer_from_str(c, ctx), kk_integer_add(kk_integer_from_str(b, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678899999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str(b, ctx), kk_integer_add(kk_integer_from_str(c, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678900000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("100000000000000000000000000000000000", ctx), kk_integer_from_str("999999999999999999", ctx), ctx), kk_integer_from_str("99999999999999999000000000000000001", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("10000000010000000", ctx), kk_integer_from_str("10000000", ctx), ctx), kk_integer_from_str("10000000000000000", ctx), ctx); } /* Borrow n */ static kk_integer_t factorial(kk_integer_t n, kk_context_t* ctx) { // 0 is a small integer and is not reference-counted - if (kk_integer_eq(n,kk_integer_from_small(0), ctx)) { + if (kk_integer_eq(n, kk_integer_from_small(0), ctx)) { return kk_integer_from_small(1); } // 1 is a small integer and is not reference-counted if (kk_integer_eq(n, kk_integer_from_small(1), ctx)) { return kk_integer_from_small(1); } - kk_integer_dup(n); - return kk_integer_mul(factorial(kk_integer_dec(kk_integer_dup(n), ctx), ctx),n, ctx); + kk_integer_dup(n, ctx); + return kk_integer_mul(factorial(kk_integer_dec(kk_integer_dup(n, ctx), ctx), ctx), n, ctx); } static void test_large(kk_context_t* ctx) { @@ -280,80 +280,80 @@ static void test_large(kk_context_t* ctx) { const char* hundredFactorial = "93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000"; const char* threeToTenThousand = "16313501853426258743032567291811547168121324535825379939348203261918257308143190787480155630847848309673252045223235795433405582999177203852381479145368112501453192355166224391025423628843556686559659645012014177448275529990373274425446425751235537341867387607813619937225616872862016504805593174059909520461668500663118926911571773452255850626968526251879139867085080472539640933730243410152186914328917354576854457274195562218013337745628502470673059426999114202540773175988199842487276183685299388927825296786440252999444785694183675323521704432195785806270123388382931770198990841300861506996108944782065015163410344894945809337689156807686673462563038164792190665340124344133980763205594364754963451564072340502606377790585114123814919001637177034457385019939060232925194471114235892978565322415628344142184842892083466227875760501276009801530703037525839157893875741192497705300469691062454369926795975456340236777734354667139072601574969834312769653557184396147587071260443947944862235744459711204473062937764153770030210332183635531818173456618022745975055313212598514429587545547296534609597194836036546870491771927625214352957503454948403635822345728774885175809500158451837389413798095329711993092101417428406774326126450005467888736546254948658602484494535938888656542746977424368385335496083164921318601934977025095780370104307980276356857350349205866078371806065542393536101673402017980951598946980664330391505845803674248348878071010412918667335823849899623486215050304052577789848512410263834811719236949311423411823585316405085306164936671137456985394285677324771775046050970865520893596151687017153855755197348199659070192954771308347627111052471134476325986362838585959552209645382089055182871854866744633737533217524880118401787595094060855717010144087136495532418544241489437080074716158404895914136451802032446707961058757633345691696743293869623745410870051851590672859347061212573446572045088465460616826082579731686004585218284333452396157730036306379421822435818001505905203918209206969662326706952623512427380240468784114535101496733983401240219840048956733689309620321613793757156727562461651933397540266795963865921590913322060572673349849253303397874242381960775337182730037783698708748781738419747698880321601186310506332869704931303076839444790968339306301273371014087248060946851793697973114432706759288546077622831002526800554849696867710280945946603669593797354642136622231192695027321229511912952940320879763123151760555959496961163141455688278842949587288399100273691880018774147568892650186152065335219113072582417699616901995530249937735219099786758954892534365835235843156112799728164123461219817343904782402517111603206575330527850752564642995318064985900815557979945885931124351303252811255254295797082281946658798705979077492469849644183166585950844953164726896146168297808178398470451561320526180542310840744843107469368959707726836608471817060598771730170755446473440774031371227437651048421606224757527085958515947273151027400662948161111284777828103531499488913672800783167888051177155427285103861736658069404797695900758820465238673970882660162285107599221418743657006872537842677883708807515850397691812433880561772652364847297019508025848964833883225165668986935081274596293983121864046277268590401580209059988500511262470167150495261908136688693861324081559046336288963037090312033522400722360882494928182809075406914319957044927504420797278117837677431446979085756432990753582588102440240611039084516401089948868433353748444104639734074519165067632941419347985624435567342072815910754484123812917487312938280670403228188813003978384081332242484646571417574404852962675165616101527367425654869508712001788393846171780457455963045764943565964887518396481296159902471996735508854292964536796779404377230965723361625182030798297734785854606060323419091646711138678490928840107449923456834763763114226000770316931243666699425694828181155048843161380832067845480569758457751090640996007242018255400627276908188082601795520167054701327802366989747082835481105543878446889896230696091881643547476154998574015907396059478684978574180486798918438643164618541351689258379042326487669479733384712996754251703808037828636599654447727795924596382283226723503386540591321268603222892807562509801015765174359627788357881606366119032951829868274617539946921221330284257027058653162292482686679275266764009881985590648534544939224296689791195355783205968492422636277656735338488299104238060289209390654467316291591219712866052661347026855261289381236881063068219249064767086495184176816629077103667131505064964190910450196502178972477361881300608688593782509793781457170396897496908861893034634895715117114601514654381347139092345833472226493656930996045016355808162984965203661519182202145414866559662218796964329217241498105206552200001"; - expect_eq(factorial(kk_integer_from_small(10), ctx),kk_integer_from_str(tenFactorial, ctx),ctx); - expect_eq(factorial(kk_integer_from_small(100), ctx),kk_integer_from_str(hundredFactorial, ctx),ctx); - expect_eq(kk_integer_pow(kk_integer_from_small(3),kk_integer_from_int(10000,ctx), ctx), kk_integer_from_str(threeToTenThousand, ctx),ctx); + expect_eq(factorial(kk_integer_from_small(10), ctx), kk_integer_from_str(tenFactorial, ctx), ctx); + expect_eq(factorial(kk_integer_from_small(100), ctx), kk_integer_from_str(hundredFactorial, ctx), ctx); + expect_eq(kk_integer_pow(kk_integer_from_small(3), kk_integer_from_int(10000, ctx), ctx), kk_integer_from_str(threeToTenThousand, ctx), ctx); // large multiply divide kk_integer_t x = kk_integer_from_str(hundredFactorial, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x), kk_integer_dup(x), ctx),kk_integer_dup(x), ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x, ctx), kk_integer_dup(x, ctx), ctx), kk_integer_dup(x, ctx), ctx), x, ctx); x = kk_integer_from_str(threeToTenThousand, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x), kk_integer_dup(x), ctx), kk_integer_dup(x), ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x, ctx), kk_integer_dup(x, ctx), ctx), kk_integer_dup(x, ctx), ctx), x, ctx); kk_integer_t y = kk_integer_from_str(hundredFactorial, ctx); x = kk_integer_from_str(threeToTenThousand, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(y), kk_integer_dup(x), ctx), y, ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(y, ctx), kk_integer_dup(x, ctx), ctx), y, ctx), x, ctx); } static void test_cdiv(kk_context_t* ctx) { - expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158",ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158",ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158",ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158",ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158", ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158", ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158", ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158", ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321",ctx), kk_integer_from_str("132435465768798",ctx), ctx), kk_integer_from_str("9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321",ctx), kk_integer_from_str("-132435465768798",ctx), ctx), kk_integer_from_str("-9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321",ctx), kk_integer_from_str("132435465768798",ctx), ctx), kk_integer_from_str("-9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321",ctx), kk_integer_from_str("-132435465768798",ctx), ctx), kk_integer_from_str("9322",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("132435465768798", ctx), ctx), kk_integer_from_str("9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-132435465768798", ctx), ctx), kk_integer_from_str("-9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("132435465768798", ctx), ctx), kk_integer_from_str("-9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-132435465768798", ctx), ctx), kk_integer_from_str("9322", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("786456456335437356436",ctx), kk_integer_from_str("-5423424653",ctx), ctx), kk_integer_from_str("-145011041298",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-93453764643534523",ctx), kk_integer_from_str("-2342",ctx), ctx), kk_integer_from_str("39903400787162",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("10000000000000000",ctx), kk_integer_from_str("-10000000000000000",ctx), ctx), kk_integer_from_str("-1",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("786456456335437356436", ctx), kk_integer_from_str("-5423424653", ctx), ctx), kk_integer_from_str("-145011041298", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-93453764643534523", ctx), kk_integer_from_str("-2342", ctx), ctx), kk_integer_from_str("39903400787162", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("10000000000000000", ctx), kk_integer_from_str("-10000000000000000", ctx), ctx), kk_integer_from_str("-1", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("98789789419609840614360398703968368740365403650364036403645046",ctx), kk_integer_from_small(-1), ctx), kk_integer_from_str("-98789789419609840614360398703968368740365403650364036403645046",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("98789789419609840614360398703968368740365403650364036403645046", ctx), kk_integer_from_small(-1), ctx), kk_integer_from_str("-98789789419609840614360398703968368740365403650364036403645046", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241",ctx),kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241",ctx), ctx), kk_integer_from_str("1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241", ctx), kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241", ctx), ctx), kk_integer_from_str("1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001", ctx), ctx); //expect_eq(kk_integer_cdiv(kk_integer_from_str(e),kk_integer_from_str(d)),kk_integer_from_str("100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1e1050",ctx), kk_integer_from_str("1e1000",ctx), ctx), kk_integer_from_str("1e50",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564",ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465",ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000",ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000",ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("9999999999999900000000000000",ctx), kk_integer_from_str("999999999999990000001",ctx), ctx), kk_integer_from_str("9999999",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1e9999",ctx), kk_integer_from_str("1e999",ctx), ctx), kk_integer_from_str("1e9000",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1e1050", ctx), kk_integer_from_str("1e1000", ctx), ctx), kk_integer_from_str("1e50", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564", ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465", ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("9999999999999900000000000000", ctx), kk_integer_from_str("999999999999990000001", ctx), ctx), kk_integer_from_str("9999999", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1e9999", ctx), kk_integer_from_str("1e999", ctx), ctx), kk_integer_from_str("1e9000", ctx), ctx); } static void test_count(kk_context_t* ctx) { - expect_eq(kk_integer_count_digits(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(1, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(9999,ctx), ctx), kk_integer_from_int(4, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(70123,ctx), ctx), kk_integer_from_int(5, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(-70123, ctx), ctx), kk_integer_from_int(5, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(10, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_neg(kk_integer_from_str(b, ctx), ctx), ctx), kk_integer_from_int(100, ctx),ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(1, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(9999, ctx), ctx), kk_integer_from_int(4, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(70123, ctx), ctx), kk_integer_from_int(5, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(-70123, ctx), ctx), kk_integer_from_int(5, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(10, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_neg(kk_integer_from_str(b, ctx), ctx), ctx), kk_integer_from_int(100, ctx), ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(0,ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(-9900, ctx), ctx), kk_integer_from_int(2,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(70000,ctx), ctx), kk_integer_from_int(4,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("100000000",ctx), ctx), kk_integer_from_int(8,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("10000000000",ctx), ctx), kk_integer_from_int(10,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("1000000000000000000",ctx), ctx), kk_integer_from_int(18,ctx),ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(-9900, ctx), ctx), kk_integer_from_int(2, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(70000, ctx), ctx), kk_integer_from_int(4, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("100000000", ctx), ctx), kk_integer_from_int(8, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("10000000000", ctx), ctx), kk_integer_from_int(10, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("1000000000000000000", ctx), ctx), kk_integer_from_int(18, ctx), ctx); } static void test_pow10(kk_context_t* ctx) { - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx),kk_integer_from_int(0,ctx), ctx), kk_integer_from_str("1234567890",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(0,ctx), kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(-1, ctx), kk_integer_from_str("12",ctx), ctx), kk_integer_from_str("-1e12",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("1234567890e8",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("-1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("-1234567890e8",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(18,ctx), ctx), kk_integer_from_str("1234567890e18",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(1234,ctx), kk_integer_from_int(14,ctx), ctx), kk_integer_from_str("1234e14",ctx),ctx); - - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(0,ctx), ctx), kk_integer_from_str("1234567890",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_int(0,ctx), kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1e13",ctx), kk_integer_from_str("12",ctx), ctx), kk_integer_from_str("-10",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("12",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("-12",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("9999999999",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("99",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(18,ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234e14",ctx), kk_integer_from_int(14,ctx), ctx), kk_integer_from_str("1234",ctx),ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(0, ctx), ctx), kk_integer_from_str("1234567890", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(0, ctx), kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(-1, ctx), kk_integer_from_str("12", ctx), ctx), kk_integer_from_str("-1e12", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("1234567890e8", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("-1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("-1234567890e8", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(18, ctx), ctx), kk_integer_from_str("1234567890e18", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(1234, ctx), kk_integer_from_int(14, ctx), ctx), kk_integer_from_str("1234e14", ctx), ctx); + + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(0, ctx), ctx), kk_integer_from_str("1234567890", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_int(0, ctx), kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1e13", ctx), kk_integer_from_str("12", ctx), ctx), kk_integer_from_str("-10", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("12", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("-12", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("9999999999", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("99", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(18, ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234e14", ctx), kk_integer_from_int(14, ctx), ctx), kk_integer_from_str("1234", ctx), ctx); } static kk_integer_t ia; @@ -369,16 +369,16 @@ static void init_nums(kk_context_t* ctx) { static kk_integer_t init_num(size_t digits, kk_context_t* ctx) { char* s = (char*)kk_malloc(digits + 1, ctx); for (size_t i = 0; i < digits; i++) { - s[i] = '0' + (9 - (i%10)); + s[i] = '0' + (9 - (i % 10)); } s[digits] = 0; - kk_integer_t x = kk_integer_from_str(s,ctx); - kk_free(s,ctx); + kk_integer_t x = kk_integer_from_str(s, ctx); + kk_free(s, ctx); return x; } static void test_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_integer_t i = kk_integer_mul(x,y,ctx); + kk_integer_t i = kk_integer_mul(x, y, ctx); kk_integer_drop(i, ctx); } /* @@ -445,8 +445,8 @@ static void test_double(kk_context_t* ctx) { i = 0; do { dx = values[i++]; - test_box_double(dx,ctx); - test_box_double(nexttoward(dx,-HUGE_VALL), ctx); + test_box_double(dx, ctx); + test_box_double(nexttoward(dx, -HUGE_VALL), ctx); test_box_double(nexttoward(dx, HUGE_VALL), ctx); test_box_double(-dx, ctx); test_box_double(nexttoward(-dx, -HUGE_VALL), ctx); @@ -484,40 +484,40 @@ static void test_count10(kk_context_t* ctx) { { uint64_t u = 0; for (int i = 0; i < 22; i++) { - test_count10_64(u-1); + test_count10_64(u - 1); test_count10_64(u); - test_count10_64(u+1); - test_count10_64(u*9); - if (u==0) u = 1; + test_count10_64(u + 1); + test_count10_64(u * 9); + if (u == 0) u = 1; else u *= 10; } u = 1; for (int i = 0; i < 64; i++) { - test_count10_64(u-1); + test_count10_64(u - 1); test_count10_64(u); - test_count10_64(u+1); - test_count10_64(u*9); - if (u==0) u = 1; + test_count10_64(u + 1); + test_count10_64(u * 9); + if (u == 0) u = 1; else u <<= 1; } } { uint32_t u = 0; for (int i = 0; i < 11; i++) { - test_count10_32(u-1); + test_count10_32(u - 1); test_count10_32(u); - test_count10_32(u+1); - test_count10_32(u*9); - if (u==0) u = 1; + test_count10_32(u + 1); + test_count10_32(u * 9); + if (u == 0) u = 1; else u *= 10; } u = 1; for (int i = 0; i < 33; i++) { - test_count10_32(u-1); + test_count10_32(u - 1); test_count10_32(u); - test_count10_32(u+1); - test_count10_32(u*9); - if (u==0) u = 1; + test_count10_32(u + 1); + test_count10_32(u * 9); + if (u == 0) u = 1; else u <<= 1; } } @@ -528,10 +528,10 @@ static void test_random(kk_context_t* ctx) { uint32_t y = kk_srandom_uint32(ctx); const size_t N = 100000000; for (size_t i = 0; i < N; i++) { - y = kk_srandom_range_uint32(60000,ctx); + y = kk_srandom_range_uint32(60000, ctx); } msecs_t end = _clock_end(start); - printf("chacha20: final: 0x%x, %6.3fs\n", y, (double)end/1000.0); + printf("chacha20: final: 0x%x, %6.3fs\n", y, (double)end / 1000.0); } static void test_ovf(kk_context_t* ctx) { @@ -562,13 +562,13 @@ static void test_ovf(kk_context_t* ctx) { for (; i > 0; i -= delta) { n = kk_integer_dec(n, ctx); } msecs_t end = _clock_end(start); kk_integer_print(n, ctx); - printf("\nint-inc-dec: %6.3fs\n", (double)end/1000.0); + printf("\nint-inc-dec: %6.3fs\n", (double)end / 1000.0); } int main() { kk_context_t* ctx = kk_get_context(); - - test_fib(50,ctx); // 12586269025 + + test_fib(50, ctx); // 12586269025 test_fib(150, ctx); // 9969216677189303386214405760200 test_fib(300, ctx); // 22223224462942044552973989346190996720666693909649976499097960 test_read("123456789", ctx); @@ -584,7 +584,7 @@ int main() { test_pow10(ctx); test_double(ctx); test_ovf(ctx); - + test_count10(ctx); //test_popcount(); test_bitcount(); @@ -714,6 +714,6 @@ kk_integer_t test_add(kk_integer_t x) { int main(int argc, char** argv ) { kk_integer_t i = test_add(int_small(argc)); if (i) printf("uh oh\n"); - else printf("hello world!\n"); + else printf("hello world!\n"); } */ From 34f3123b4021832e6c0d0ad433227a4c9ff1bf08 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 6 Dec 2022 21:42:40 -0800 Subject: [PATCH 091/233] wip: can compile std/core/types --- kklib/include/kklib.h | 26 +++++++--- kklib/include/kklib/box.h | 10 ++-- kklib/include/kklib/integer.h | 8 +-- kklib/include/kklib/platform.h | 13 +++-- kklib/src/box.c | 20 ++++---- kklib/src/init.c | 2 +- kklib/src/integer.c | 18 +++---- kklib/test/main.c | 2 +- lib/std/core/types-ctail-inline.h | 8 +-- lib/std/core/types.kk | 2 +- src/Backend/C/FromCore.hs | 81 ++++++++++++++++--------------- src/Common/Syntax.hs | 29 +++++++---- src/Compiler/Options.hs | 12 +++-- 13 files changed, 131 insertions(+), 100 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index d794691b0..02b3ffaa1 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -330,7 +330,7 @@ static inline void kk_block_set_invalid(kk_block_t* b) { } static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { - return (b != NULL && ((intptr_t)b & 1) == 0 && *((int64_t*)b) != KK_I64(0xDFDFDFDFDFDFDFDF)); // already freed! + return (b != NULL && ((uintptr_t)b & 1) == 0 && *((uint64_t*)b) != KK_U64(0xDFDFDFDFDFDFDFDF)); // already freed! } @@ -586,7 +586,8 @@ static inline void kk_block_large_init(kk_block_large_t* b, kk_ssize_t size, kk_ uint8_t bscan_fsize = (scan_fsize >= KK_SCAN_FSIZE_MAX ? KK_SCAN_FSIZE_MAX : (uint8_t)scan_fsize); kk_header_init(&b->_block.header, bscan_fsize, tag); kk_assert_internal(scan_fsize > 0); - b->large_scan_fsize = kk_intf_box(scan_fsize); + kk_assert_internal(scan_fsize <= KK_INTF_MAX); + b->large_scan_fsize = kk_intf_box((kk_intf_t)scan_fsize); } typedef kk_block_t* kk_reuse_t; @@ -896,7 +897,7 @@ static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { #if KK_COMPRESS intptr_t i = (intptr_t)p - ctx->heap_base; kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); - return _kk_make_ptr((kk_int_b)i); + return _kk_make_ptr((kk_intb_t)i); #else kk_unused(ctx); return _kk_make_ptr((kk_intb_t)p); @@ -943,6 +944,11 @@ static inline kk_decl_const kk_basetype_t kk_basetype_from_ptr(kk_ptr_t p, kk_co return b; } +static inline kk_decl_const kk_basetype_t kk_basetype_invalid_from_tag(kk_tag_t t) { + kk_basetype_t b = { kk_intf_encode(t,0) }; + return b; +} + static inline kk_decl_const bool kk_basetype_eq(kk_basetype_t x, kk_basetype_t y) { return (x.bbox == y.bbox); } @@ -1019,7 +1025,7 @@ static inline void kk_basetype_decref(kk_basetype_t b, kk_context_t* ctx) { #define kk_basetype_as(tp,v,ctx) (kk_block_as(tp,kk_basetype_as_ptr(v,ctx))) #define kk_basetype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_basetype_as_ptr(v,ctx),tag)) #define kk_basetype_alloc(struct_tp,scan_fsize,tag,ctx) (kk_basetype_from_ptr(kk_block_alloc(kk_ssizeof(struct_tp),scan_fsize,tag,ctx),ctx)) - +#define kk_basetype_dup_as(tp,v,ctx) (kk_basetype_dup(v,ctx)) #define kk_basetype_null { _kk_make_value(0) } static inline bool kk_basetype_is_null(kk_basetype_t b) { @@ -1362,7 +1368,7 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { Functions --------------------------------------------------------------------------------------*/ -#define kk_function_as(tp,fun) kk_basetype_as_assert(tp,fun,KK_TAG_FUNCTION) +#define kk_function_as(tp,fun,ctx) kk_basetype_as_assert(tp,fun,KK_TAG_FUNCTION,ctx) #define kk_function_alloc_as(tp,scan_fsize,ctx) kk_block_alloc_as(tp,scan_fsize,KK_TAG_FUNCTION,ctx) #define kk_function_call(restp,argtps,f,args,ctx) ((restp(*)argtps)(kk_kkfun_ptr_unbox(kk_basetype_as(struct kk_function_s*,f,ctx)->fun,ctx)))args @@ -1377,8 +1383,8 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { #define kk_define_static_function(name,cfun,ctx) \ static kk_function_t name = kk_basetype_null; \ if (kk_basetype_is_null(name)) { \ - name = kk_basetype_alloc(struct kk_function_s, 1, ctx); \ - name->fun = kk_kkfun_ptr_box(&cfun, ctx); \ + name = kk_basetype_alloc(struct kk_function_s, 1, KK_TAG_FUNCTION, ctx); \ + kk_basetype_as(struct kk_function_s*, name, ctx)->fun = kk_kkfun_ptr_box(&cfun, ctx); \ } #endif @@ -1387,10 +1393,14 @@ kk_function_t kk_function_id(kk_context_t* ctx); kk_function_t kk_function_null(kk_context_t* ctx); bool kk_function_is_null(kk_function_t f, kk_context_t* ctx); -static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v, kk_context_t* ctx) { +static inline kk_decl_pure kk_function_t kk_function_unbox_assert(kk_box_t v, kk_context_t* ctx) { return kk_basetype_unbox_assert(v, KK_TAG_FUNCTION, ctx); } +static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v) { + return kk_basetype_unbox(v); +} + static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d) { return kk_basetype_box(d); } diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 72d37a55f..5e6bd9e9c 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -286,11 +286,11 @@ static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag, kk_context } -static inline kk_uintx_t kk_enum_unbox(kk_box_t b) { +static inline kk_uintf_t kk_enum_unbox(kk_box_t b) { return kk_uintf_unbox(b); } -static inline kk_box_t kk_enum_box(kk_uintx_t u) { +static inline kk_box_t kk_enum_box(kk_uintf_t u) { return kk_uintf_box(u); } @@ -321,10 +321,10 @@ typedef struct kk_boxed_value_s { const size_t kk__max_scan_fsize = sizeof(tp)/sizeof(kk_box_t); \ kk_box_t* _fields = (kk_box_t*)(&x); \ for (size_t i = 0; i < kk__max_scan_fsize; i++) { _fields[i] = kk_box_any(ctx); } \ - kk_block_decref(kk_ptr_unbox(box),ctx); \ + kk_block_decref(kk_ptr_unbox(box,ctx),ctx); \ } \ else { \ - p = kk_basetype_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX); \ + p = kk_block_as(kk_boxed_value_t, kk_block_unbox(box, KK_TAG_BOX, ctx)); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ } \ } while(0) @@ -334,7 +334,7 @@ typedef struct kk_boxed_value_s { kk_boxed_value_t p = kk_block_assert(kk_boxed_value_t, kk_block_alloc(sizeof(kk_block_t) + sizeof(tp), scan_fsize, KK_TAG_BOX, ctx), KK_TAG_BOX); \ const tp valx = val; /* ensure we can take the address */ \ memcpy(&p->data,&valx,sizeof(tp)); /* avoid aliasing warning: *((tp*)(&p->data)) = val; */ \ - x = kk_basetype_box(p); \ + x = kk_block_box(&p->_block,ctx); \ } while(0) // `box_any` is used to return when yielding diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 206360d3a..2b0d8f65e 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -798,8 +798,8 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); - kk_intf_t i = kk_sar(_kk_integer_value(x), 1); - kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t i = kk_sarf(_kk_integer_value(x), 1); + kk_intf_t j = kk_sarf(_kk_integer_value(y), 1); kk_intf_t z = i*j; if kk_likely(z == (kk_smallint_t)(z)) { kk_assert_internal((z&3) == 0); @@ -827,8 +827,8 @@ static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_cdiv_small(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); kk_assert_internal(!kk_integer_is_zero_borrow(y)); - kk_intf_t i = kk_sar(_kk_integer_value(x), 1); - kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t i = kk_sarf(_kk_integer_value(x), 1); + kk_intf_t j = kk_sarf(_kk_integer_value(y), 1); return kk_integer_from_small(i/j); } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 6bc5714a5..d233da07e 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -368,7 +368,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE KK_INTPTR_SIZE +#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) @@ -381,6 +381,7 @@ typedef uintptr_t kk_uintb_t; #define KK_INTB_MAX INTPTR_MAX #define KK_INTB_MIN INTPTR_MIN #define KK_IB(i) KK_IP(i) +#define KK_UB(i) KK_UP(i) #define PRIdIB "zd" #elif (KK_INTB_SIZE == 8 && KK_INTB_SIZE < KK_INTPTR_SIZE) #define KK_COMPRESS 1 @@ -389,6 +390,7 @@ typedef uint64_t kk_uintb_t; #define KK_INTB_MAX INT64_MAX #define KK_INTB_MIN INT64_MIN #define KK_IB(i) KK_I64(i) +#define KK_UB(i) KK_U64(i) #define PRIdIB PRIdI64 #elif (KK_INTB_SIZE == 4 && KK_INTB_SIZE < KK_INTPTR_SIZE) #define KK_COMPRESS 1 @@ -397,6 +399,7 @@ typedef uint32_t kk_uintb_t; #define KK_INTB_MAX INT32_MAX #define KK_INTB_MIN INT32_MIN #define KK_IB(i) KK_I32(i) +#define KK_UB(i) KK_U32(i) #define PRIdIB PRIdI32 #else #error "the given platform boxed integer size is (currently) not supported" @@ -417,11 +420,11 @@ typedef size_t kk_uintf_t; #define KK_INTF_MIN KK_SSIZE_MIN #else typedef kk_intb_t kk_intf_t; -typedef kk_intb_t kk_uintf_t; +typedef kk_uintb_t kk_uintf_t; #define KK_IF(i) KK_IB(i) -#define KK_INTF_SIZE 8 -#define KK_INTF_MAX INT64_MAX -#define KK_INTF_MIN INT64_MIN +#define KK_INTF_SIZE KK_INTB_SIZE +#define KK_INTF_MAX KK_INTB_MAX +#define KK_INTF_MIN KK_INTB_MIN #define PRIdIF PRIdIB #endif #define KK_INTF_BITS (8*KK_INTF_SIZE) diff --git a/kklib/src/box.c b/kklib/src/box.c index f1659eee9..d2d4bebdc 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -33,7 +33,7 @@ intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx) { if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { - return kk_intf_box(i); + return kk_intf_box((kk_intf_t)i); } else { boxed_intptr_t bi = kk_block_alloc_as(struct kk_boxed_intptr_s, 0, KK_TAG_INTPTR, ctx); @@ -43,7 +43,7 @@ kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx) { } -#if (KK_INTPTR_SIZE <= 8) +#if (KK_INTF_SIZE <= 8) typedef struct kk_boxed_int64_s { kk_block_t _block; int64_t value; @@ -76,7 +76,7 @@ kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { #endif -#if (KK_INTPTR_SIZE <= 4) +#if (KK_INTF_SIZE <= 4) typedef struct kk_boxed_int32_s { kk_block_t _block; int32_t value; @@ -104,12 +104,12 @@ kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { else { boxed_int32_t bi = kk_block_alloc_as(struct kk_boxed_int32_s, 0, KK_TAG_INT32, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } #endif -#if (KK_INTPTR_SIZE <= 2) +#if (KK_INTF_SIZE <= 2) typedef struct kk_boxed_int16_s { kk_block_t _block; int16_t value; @@ -142,7 +142,7 @@ kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { } #endif -#if KK_SSIZE_SIZE == KK_INTPTR_SIZE +#if KK_SSIZE_SIZE == KK_INTF_SIZE kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_intptr_box(i, ctx); } @@ -240,7 +240,7 @@ kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ) { Double boxing on 64-bit systems ----------------------------------------------------------------*/ -#if (KK_INTPTR_SIZE == 8) && KK_BOX_DOUBLE64 +#if (KK_INTF_SIZE == 8) && KK_BOX_DOUBLE64 // Generic double allocation in the heap typedef struct kk_boxed_double_s { kk_block_t _block; @@ -352,7 +352,7 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { Float boxing on 32-bit systems ----------------------------------------------------------------*/ -#if (KK_INTPTR_SIZE == 4) +#if (KK_INTF_SIZE == 4) // Generic float allocation in the heap typedef struct kk_boxed_float_s { kk_block_t _block; @@ -376,7 +376,7 @@ kk_box_t kk_float_box(float f, kk_context_t* ctx) { kk_unused(ctx); uint32_t i = kk_bits_from_float(f); if ((int32_t)i >= 0) { // positive? - kk_box_t b = { ((uintptr_t)i<<1)|1 }; + kk_box_t b = { ((intptr_t)i<<1)|1 }; return b; } else { @@ -390,7 +390,7 @@ float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { float f; if (kk_box_is_value(b)) { // positive float - uint32_t u = kk_shrp(b.box, 1); + uint32_t u = (uint32_t)kk_shrp(b.box, 1); f = kk_bits_to_float(u); } else { diff --git a/kklib/src/init.c b/kklib/src/init.c index cfd7c4649..1a512f50d 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -195,7 +195,7 @@ static kk_decl_thread kk_context_t* context; #define kk_assign_const(tp,field) ((tp*)&(field))[0] static struct { kk_block_t _block; kk_integer_t cfc; } kk_evv_empty_static = { - { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UP(0))^0x02) /*==-1 smallint*/} + { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UB(0))^0x02) /*==-1 smallint*/} }; kk_ptr_t kk_evv_empty_singleton = &kk_evv_empty_static._block; diff --git a/kklib/src/integer.c b/kklib/src/integer.c index 6e13ff139..84872672f 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -1365,7 +1365,7 @@ kk_integer_t kk_integer_cdiv_cmod_generic(kk_integer_t x, kk_integer_t y, kk_int } if (cmp==0) { if (mod) *mod = kk_integer_zero; - kk_intx_t i = (bigint_is_neg_(bx) == bigint_is_neg_(by) ? 1 : -1); + kk_intf_t i = (bigint_is_neg_(bx) == bigint_is_neg_(by) ? 1 : -1); kk_integer_drop(x, ctx); kk_integer_drop(y, ctx); return kk_integer_from_small(i); @@ -1554,8 +1554,8 @@ void kk_integer_print(kk_integer_t x, kk_context_t* ctx) { ----------------------------------------------------------------------*/ // count trailing decimal zeros -static kk_intx_t int_ctz(kk_intx_t x) { - kk_intx_t count = 0; +static int int_ctz(kk_intx_t x) { + int count = 0; for (; x != 0 && (x%10) == 0; x /= 10) { count++; } @@ -1582,11 +1582,11 @@ kk_integer_t kk_integer_ctz(kk_integer_t x, kk_context_t* ctx) { } } -static kk_intx_t int_count_digits(kk_intx_t x) { +static kk_intf_t int_count_digits(kk_intf_t x) { // make positive kk_uintx_t u; if (x < 0) { - u = (kk_uintx_t)(x == KK_INTX_MIN ? KK_INTX_MAX : -x); // careful for overflow + u = (kk_uintx_t)(x == KK_INTF_MIN ? KK_INTF_MAX : -x); // careful for overflow } else { u = (kk_uintx_t)x; @@ -1594,9 +1594,9 @@ static kk_intx_t int_count_digits(kk_intx_t x) { return kk_bits_digits(u); } -static kk_intx_t bigint_count_digits(kk_bigint_t* x, kk_context_t* ctx) { +static kk_intf_t bigint_count_digits(kk_bigint_t* x, kk_context_t* ctx) { kk_assert_internal(x->count > 0); - kk_intx_t count; + kk_intf_t count; #if (DIGIT_BITS==64) count = kk_bits_digits64(x->digits[x->count-1]) + LOG_BASE*(x->count - 1); #else @@ -1635,7 +1635,7 @@ kk_integer_t kk_integer_mul_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* // TODO: raise error return kk_integer_zero; } - kk_intx_t i = kk_smallint_from_integer(p); + kk_intf_t i = kk_smallint_from_integer(p); // negative? if (i < 0) { @@ -1681,7 +1681,7 @@ kk_integer_t kk_integer_cdiv_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* // TODO: raise error return kk_integer_zero; } - kk_intx_t i = kk_smallint_from_integer(p); + kk_intf_t i = kk_smallint_from_integer(p); // negative? if (i < 0) { diff --git a/kklib/test/main.c b/kklib/test/main.c index f3c54d7eb..13a867687 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -73,7 +73,7 @@ static intptr_t add(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); static intptr_t sub(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); return check(x - y); } static intptr_t mul(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); return check(x * y); } -static void testx(const char* name, iop* op, xop* opx, intptr_t i, intptr_t j, kk_context_t* ctx) { +static void testx(const char* name, iop* op, xop* opx, kk_intf_t i, kk_intf_t j, kk_context_t* ctx) { kk_integer_t x = _kk_new_integer(i); kk_integer_t y = _kk_new_integer(j); intptr_t k = _kk_integer_value(op(x, y, ctx)); diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h index e09c1496c..4679bb6bd 100644 --- a/lib/std/core/types-ctail-inline.h +++ b/lib/std/core/types-ctail-inline.h @@ -24,7 +24,7 @@ static inline kk_std_core_types__ctail kk_ctail_unit(kk_context_t* ctx) { static inline kk_box_t kk_ctail_apply_linear( kk_std_core_types__ctail acc, kk_box_t child ) { #if 1 if (kk_likely(acc.hole != NULL)) { - kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,kk_get_context()))); *(acc.hole) = child; return acc.res; } @@ -40,8 +40,8 @@ static inline kk_box_t kk_ctail_apply_linear( kk_std_core_types__ctail acc, kk_b static inline kk_box_t kk_ctail_apply_nonlinear( kk_std_core_types__ctail acc, kk_box_t child, kk_context_t* ctx ) { // note: written like this for best codegen; be careful when rewriting. - if (acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res))) { // no kk_likely seem slightly better - kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res))); + if (acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))) { // no kk_likely seem slightly better + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); *(acc.hole) = child; // in-place update the hole with the child return acc.res; } @@ -49,7 +49,7 @@ static inline kk_box_t kk_ctail_apply_nonlinear( kk_std_core_types__ctail acc, k return child; } else { - kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res))); + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); return kk_ctail_context_copy_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child } } diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index d137e923d..be59725fb 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -267,7 +267,7 @@ pub inline extern modify : forall ( ref : ref, f : forall local // If a heap effect is unobservable, the heap effect can be erased by using the `run` fun. // See also: _State in Haskell, by Simon Peyton Jones and John Launchbury_. pub extern run : forall ( action : forall () -> ,read,write | e> a ) -> e a - c inline "(kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),#1,(#1,kk_context())))" + c inline "(kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),#1,(#1,kk_context()),kk_context()))" cs inline "Primitive.Run<##2>(#1)" js inline "((#1)())" diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 57f2fb119..8183564e8 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -456,8 +456,8 @@ genTypeDefPre (Data info isExtend) <-> (if dataReprMayHaveSingletons dataRepr then (text "typedef kk_datatype_t" <+> ppName (typeClassName name) <.> semi) - else (text "typedef struct" <+> ppName (typeClassName name) <.> text "_s*" <+> ppName (typeClassName name) <.> semi)) - + else ( -- text "typedef struct" <+> ppName (typeClassName name) <.> text "_s*" <+> ppName (typeClassName name) <.> semi)) + text "typedef kk_basetype_t" <+> ppName (typeClassName name) <.> semi)) genTypeDefPost:: TypeDef -> Asm () genTypeDefPost (Synonym synInfo) @@ -653,7 +653,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount then [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi , tmp <.> text "._tag =" <+> ppConTag con conRepr dataRepr <.> semi] ++ map (assignField (\fld -> tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> fld)) conFields - ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null;" + ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null();" | i <- [scanCount..(maxScanCount-1)]] else [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi {- <+> text "= {0}; // zero initializes all fields" -} ] ++ map (assignField (\fld -> tmp <.> text "." <.> fld)) conFields @@ -683,7 +683,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount then text "return kk_datatype_from_base" <.> parens base <.> semi else text "return" <+> base <.> semi]) -} - [text "return" <+> conBaseCastNameInfo con <.> parens tmp <.> semi]) + [text "return" <+> conBaseCastNameInfo con <.> arguments [tmp] <.> semi]) ) genConstructorBaseCast :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> Asm () @@ -695,12 +695,14 @@ genConstructorBaseCast info dataRepr con conRepr _ | dataReprIsValue dataRepr -> return () _ -> emitToH $ text "static inline" <+> ppName (typeClassName (dataInfoName info)) <+> conBaseCastNameInfo con - <.> tupled [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] + <.> parameters [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] <+> block ( let base = text "&_x->_base" - in if (dataReprMayHaveSingletons dataRepr) - then text "return kk_datatype_from_base" <.> parens base <.> semi - else text "return" <+> base <.> semi + in text "return" <+> + (if (dataReprMayHaveSingletons dataRepr) + then text "kk_datatype_from_base" + else text "kk_basetype_from_base") + <+> arguments [base] <.> semi ) @@ -711,12 +713,12 @@ genConstructorAccess info dataRepr con conRepr else gen where gen = emitToH $ text "static inline struct" <+> ppName (conInfoName con) <.> text "*" <+> conAsName con - <.> tupled [ppName (typeClassName (dataInfoName info)) <+> text "x"] + <.> parameters [ppName (typeClassName (dataInfoName info)) <+> text "x"] <+> block( vcat $ [-- text "assert(" <.> conTestName con <.> tupled [text "x"] <.> text ");", text "return" <+> text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_as_assert" else "kk_basetype_as_assert") <.> - tupled [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", + arguments [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr <+> text "/* _tag */")] <.> semi] ) @@ -803,18 +805,19 @@ genUnbox name info dataRepr , ppName name <+> text "_unbox;" , text "kk_valuetype_unbox_" <.> arguments [ppName name, text "_p", text "_unbox", text "_x"] <.> semi -- borrowing , text "if (_ctx!=NULL && _p!=NULL)" <+> block ( - text "if (kk_basetype_is_unique(_p)) { kk_basetype_free(_p,_ctx); } else" <+> block ( - vcat [ppName name <.> text "_dup(_unbox);" - ,text "kk_basetype_decref" <.> arguments [text "_p"] <.> semi] + text "if (kk_base_type_is_unique(_p)) { kk_base_type_free(_p,_ctx); } else" <+> block ( + vcat [ppName name <.> text "_dup(_unbox,_ctx);" + ,text "kk_base_type_decref" <.> arguments [text "_p"] <.> semi] ) ) -- , text "else {" <+> ppName name <.> text "_dup(_unbox); }" , text "return _unbox" ] -- text "unbox_valuetype" <.> arguments [ppName name, text "x"] _ -> text "return" - <+> (if dataReprMayHaveSingletons dataRepr - then text "kk_datatype_unbox(_x)" - else text "kk_basetype_unbox_as" <.> tupled [ppName name, text "_x"]) + <+> ((if dataReprMayHaveSingletons dataRepr + then text "kk_datatype_unbox" + else text "kk_basetype_unbox") + <.> tupled [text "_x"]) ) <.> semi) @@ -837,12 +840,12 @@ genDupDrop name info dataRepr conInfos genIsUnique :: Name -> DataInfo -> DataRepr -> Asm () genIsUnique name info dataRepr = emitToH $ - text "static inline bool" <+> ppName name <.> text "_is_unique" <.> tupled [ppName name <+> text "_x"] <+> block ( + text "static inline bool" <+> ppName name <.> text "_is_unique" <.> parameters [ppName name <+> text "_x"] <+> block ( text "return" <+> (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_is_unique(_x)" - else text "kk_basetype_is_unique(_x)" - ) <.> semi) + then text "kk_datatype_is_unique" + else text "kk_basetype_is_unique" + ) <.> arguments [text "_x"] <.> semi) genFree :: Name -> DataInfo -> DataRepr -> Asm () genFree name info dataRepr @@ -886,12 +889,12 @@ genDropNFun name info dataRepr genReuse :: Name -> DataInfo -> DataRepr -> Asm () genReuse name info dataRepr = emitToH $ - text "static inline kk_reuse_t" <+> ppName name <.> text "_reuse" <.> tupled [ppName name <+> text "_x"] <+> block ( + text "static inline kk_reuse_t" <+> ppName name <.> text "_reuse" <.> parameters [ppName name <+> text "_x"] <+> block ( text "return" <+> (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_reuse(_x)" - else text "kk_basetype_reuse(_x)" - ) <.> semi) + then text "kk_datatype_reuse" + else text "kk_basetype_reuse" + ) <.> arguments [text "_x"] <.> semi) genHole :: Name -> DataInfo -> DataRepr -> Asm () genHole name info dataRepr @@ -901,7 +904,7 @@ genHole name info dataRepr -- holes must be trace-able and look like values (least-significant-bit==1) (if (dataReprMayHaveSingletons dataRepr) then text "kk_datatype_from_tag((kk_tag_t)0)" - else parens (ppName name) <.> text "(1)" + else text "kk_basetype_invalid_from_tag((kk_tag_t)0)" ) <.> semi) @@ -927,7 +930,7 @@ genDupDropX isDup name info dataRepr conInfos = emitToH $ text "static inline" <+> (if isDup then ppName name <+> ppName name <.> text "_dup" else text "void" <+> ppName name <.> text "_drop") - <.> (if isDup then tupled else parameters) [ppName name <+> text "_x"] + <.> parameters [ppName name <+> text "_x"] <+> block (vcat (dupDropTests)) where ret = (if isDup then [text "return _x;"] else []) @@ -937,10 +940,12 @@ genDupDropX isDup name info dataRepr conInfos | dataRepr <= DataStruct = map (genDupDropTests isDup dataRepr (length conInfos)) (zip conInfos [1..]) ++ ret | otherwise = if (isDup) then [text "return" <+> (if dataReprMayHaveSingletons dataRepr - then text "kk_datatype_dup(_x)" - else text "kk_basetype_dup_as" <.> tupled [ppName name, text "_x"]) + then text "kk_datatype_dup" <.> arguments [text "_x"] + else -- text "kk_basetype_dup_as" <.> arguments [ppName name, text "_x"]) + text "kk_basetype_dup" <.> arguments [text "_x"]) <.> semi] - else [text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_drop" else "kk_basetype_drop") + else [text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_drop" + else "kk_basetype_drop") <.> arguments [text "_x"] <.> semi] genDupDropIso :: Bool -> (ConInfo,ConRepr,[(Name,Type)],Int) -> Doc @@ -984,11 +989,11 @@ genDupCall tp arg = hcat $ genDupDropCall True tp arg genDropCall tp arg = hcat $ genDupDropCall False tp arg genDupDropCall :: Bool -> Type -> Doc -> [Doc] -genDupDropCall isDup tp arg = if (isDup) then genDupDropCallX "dup" tp (parens arg) +genDupDropCall isDup tp arg = if (isDup) then genDupDropCallX "dup" tp (arguments [arg]) else genDupDropCallX "drop" tp (arguments [arg]) genIsUniqueCall :: Type -> Doc -> [Doc] -genIsUniqueCall tp arg = case genDupDropCallX "is_unique" tp (parens arg) of +genIsUniqueCall tp arg = case genDupDropCallX "is_unique" tp (arguments [arg]) of [call] -> [text "kk_likely" <.> parens call] cs -> cs @@ -1002,7 +1007,7 @@ genDropReuseCall :: Type -> [Doc] -> [Doc] genDropReuseCall tp args = genDupDropCallX "dropn_reuse" tp (arguments args) genReuseCall :: Type -> Doc -> [Doc] -genReuseCall tp arg = genDupDropCallX "reuse" tp (parens arg) +genReuseCall tp arg = genDupDropCallX "reuse" tp (arguments [arg]) genDropNCall :: Type -> [Doc] -> [Doc] genDropNCall tp args = genDupDropCallX "dropn" tp (arguments args) @@ -1113,9 +1118,9 @@ genLambda params eff body ,text "return kk_function_dup(_fself);"] else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty (scanCount + 1) -- +1 for the _base.fun ] <.> semi - ,text "_self->_base.fun = kk_cfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] + ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] - ++ [text "return &_self->_base;"]) + ++ [text "return kk_basetype_from_base(&_self->_base, kk_context());"]) ) @@ -1125,7 +1130,7 @@ genLambda params eff body let funDef = funSig <+> block ( (if (null fields) then text "kk_unused(_fself);" else let dups = braces (hcat [genDupCall tp (ppName name) <.> semi | (name,tp) <- fields]) - in vcat ([structDoc <.> text "* _self = kk_function_as" <.> tupled [structDoc <.> text "*",text "_fself"] <.> semi] + in vcat ([structDoc <.> text "* _self = kk_function_as" <.> arguments [structDoc <.> text "*",text "_fself"] <.> semi] ++ [ppType tp <+> ppName name <+> text "= _self->" <.> ppName name <.> semi <+> text "/*" <+> pretty tp <+> text "*/" | (name,tp) <- fields] ++ [text "kk_drop_match" <.> arguments [text "_self",dups,text "{}"]] )) @@ -1513,7 +1518,7 @@ genPatternTest doTest gfree (exprDoc,pattern) = do local <- newVarName "con" let next = genNextPatterns (\self fld -> self <.> text "->" <.> fld) (ppDefName local) (typeOf tname) patterns typeDoc = text "struct" <+> ppName (conInfoName conInfo) <.> text "*" - assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> tupled [exprDoc] <.> semi + assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> arguments [exprDoc] <.> semi return [(xtest [conTestName conInfo <.> parens exprDoc],[assign],next)] patternVarFree pat @@ -1843,7 +1848,7 @@ genAppNormal f args (map (ppType . snd) argTps) ++ [text "kk_context_t*"])) _ -> failure $ ("Backend.C.genAppNormal: expecting function type: " ++ show (pretty (typeOf f))) - return (fdecls ++ decls, text "kk_function_call" <.> tupled [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) + return (fdecls ++ decls, text "kk_function_call" <.> arguments [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) -- Assign fields to a constructor. Used in: genAppNormal on conAssignFields @@ -1854,7 +1859,7 @@ genAssignFields tmp conName reuseName fieldNames fieldValues tmpDecl = conTp <+> tmp <+> text "=" <+> parens conTp <.> ppName (getName reuseName) <.> semi assigns = [tmp <.> text "->" <.> ppName fname <+> text "=" <+> fval <.> semi | (fname,fval) <- zip fieldNames fieldDocs] - result = conBaseCastName (getName conName) <.> parens tmp + result = conBaseCastName (getName conName) <.> arguments [tmp] return (decls, tmpDecl, assigns, result) diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index f7b6acbe0..f4c5af00d 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -23,7 +23,8 @@ module Common.Syntax( Visibility(..) , HandlerSort(..) , isHandlerInstance, isHandlerNormal , OperationSort(..), readOperationSort - , Platform(..), platform32, platform64, platformCS, platformJS + , Platform(..), platform32, platform64, platformCS, platformJS, platform64c + , platformHasCompressedFields , alignedSum, alignedAdd, alignUp , BuildType(..) ) where @@ -64,19 +65,27 @@ instance Show Target where C _ -> "c" Default -> "" - -data Platform = Platform{ sizePtr :: Int -- sizeof(intptr_t) - , sizeSize :: Int -- sizeof(size_t) +data Platform = Platform{ sizePtr :: Int -- sizeof(intptr_t) + , sizeSize :: Int -- sizeof(size_t) + , sizeField :: Int -- sizeof(kk_field_t), usually uintptr_t but may be smaller for compression } -platform32, platform64 :: Platform -platform32 = Platform 4 4 -platform64 = Platform 8 8 -platformJS = Platform 8 4 -platformCS = Platform 8 4 +platform32, platform64, platform64c, platformJS, platformCS :: Platform +platform32 = Platform 4 4 4 +platform64 = Platform 8 8 8 +platform64c = Platform 8 8 4 -- compressed fields +platformJS = Platform 8 4 8 +platformCS = Platform 8 4 8 + + +platformHasCompressedFields (Platform sp _ sf) = (sp /= sf) instance Show Platform where - show (Platform sp ss) = "Platform(sizeof(void*)=" ++ show sp ++ ",sizeof(size_t)=" ++ show ss ++ ")" + show (Platform sp ss sf) = "Platform(sizeof(void*)=" ++ show sp ++ + ",sizeof(size_t)=" ++ show ss ++ + ",sizeof(kk_box_t)=" ++ show sf ++ + ")" + alignedSum :: Int -> [Int] -> Int alignedSum start xs = foldl alignedAdd start xs diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index cd4da77f6..369d0f580 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -440,6 +440,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip [("c", \f -> f{ target=C LibC, platform=platform64 }), ("c64", \f -> f{ target=C LibC, platform=platform64 }), ("c32", \f -> f{ target=C LibC, platform=platform32 }), + ("c64c", \f -> f{ target=C LibC, platform=platform64c }), ("js", \f -> f{ target=JS JsNode, platform=platformJS }), ("jsnode", \f -> f{ target=JS JsNode, platform=platformJS }), ("jsweb", \f -> f{ target=JS JsWeb, platform=platformJS }), @@ -660,9 +661,10 @@ processOptions flags0 opts ccCheckExist cc let stdAlloc = if asan then True else useStdAlloc flags -- asan implies useStdAlloc cdefs = ccompDefs flags - ++ if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))] - ++ if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")] - ++ if optctailCtxPath flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")] + ++ (if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))]) + ++ (if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")]) + ++ (if optctailCtxPath flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")]) + ++ (if platformHasCompressedFields (platform flags) then [("KK_INTB_SIZE",show (sizeField (platform flags)))] else []) -- vcpkg -- (vcpkgRoot,vcpkg) <- vcpkgFindRoot (vcpkgRoot flags) @@ -957,7 +959,9 @@ buildVariant flags Wasm -> "-wasm" ++ show (8*sizePtr (platform flags)) WasmJs -> "-wasmjs" WasmWeb-> "-wasmweb" - _ -> "") + _ | platformHasCompressedFields (platform flags) + -> "-x" ++ show (8 * sizePtr (platform flags)) ++ "c" + | otherwise -> "") JS _ -> "js" _ -> show (target flags) in pre ++ "-" ++ show (buildType flags) From b953182e2dff4a2fbfee8d4d8a0c8fe146717e4e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 7 Dec 2022 10:57:19 -0800 Subject: [PATCH 092/233] wip: can run rbtree benchmark --- kklib/include/kklib.h | 316 ++++++++++++++------------------- kklib/include/kklib/box.h | 21 ++- kklib/include/kklib/bytes.h | 4 +- kklib/include/kklib/integer.h | 4 + kklib/include/kklib/platform.h | 4 + kklib/include/kklib/string.h | 4 +- kklib/src/box.c | 2 +- kklib/src/bytes.c | 6 +- kklib/src/init.c | 53 ++++-- kklib/src/integer.c | 2 +- kklib/src/os.c | 2 +- kklib/src/refcount.c | 8 +- kklib/src/thread.c | 2 +- kklib/src/vector.c | 2 +- kklib/test/main.c | 6 +- lib/std/core.kk | 14 +- lib/std/core/core-inline.c | 68 +++---- lib/std/core/core-inline.h | 13 +- lib/std/core/hnd-inline.c | 126 ++++++------- lib/std/core/hnd-inline.h | 88 +++++---- src/Backend/C/FromCore.hs | 136 +++++++------- 21 files changed, 445 insertions(+), 436 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 02b3ffaa1..66b3f646b 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 95 // modify on changes to trigger recompilation +#define KKLIB_BUILD 96 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks @@ -172,10 +172,6 @@ typedef struct kk_integer_s { } kk_integer_t; -typedef struct kk_basetype_s { - kk_intb_t bbox; -} kk_basetype_t; - // A general datatype with constructors and singletons is either // an enumeration (with the lowest bit set as: 4*tag + 1) or a `kk_block_t*` pointer. @@ -184,6 +180,8 @@ typedef struct kk_datatype_s { kk_intb_t dbox; } kk_datatype_t; +// Typedef to signify datatypes that have no singletons (and are always a pointer) +typedef kk_datatype_t kk_datatype_ptr_t; // boxed forward declarations static inline kk_intf_t kk_intf_unbox(kk_box_t v); @@ -361,7 +359,7 @@ struct kk_function_s { kk_box_t fun; // kk_kkfun_ptr_t // followed by free variables }; -typedef kk_basetype_t kk_function_t; +typedef kk_datatype_ptr_t kk_function_t; // A vector is an array of boxed values, or an empty singleton typedef kk_datatype_t kk_vector_t; @@ -385,7 +383,7 @@ struct kk_box_any_s { kk_block_t _block; kk_integer_t _unused; }; -typedef kk_basetype_t kk_box_any_t; +typedef kk_datatype_t kk_box_any_t; // Workers run in a task_group typedef struct kk_task_group_s kk_task_group_t; @@ -400,17 +398,14 @@ typedef enum kk_yield_kind_e { } kk_yield_kind_t; typedef struct kk_yield_s { - int32_t marker; // marker of the handler to yield to + int32_t marker; // marker of the handler to yield to kk_function_t clause; // the operation clause to execute when the handler is found - kk_ssize_t conts_count; // number of continuations in `conts` + kk_intf_t conts_count; // number of continuations in `conts` kk_function_t conts[KK_YIELD_CONT_MAX]; // fixed array of continuations. The final continuation `k` is // composed as `fN â—‹ ... â—‹ f2 â—‹ f1` if `conts = { f1, f2, ..., fN }` // if the array becomes full, a fresh array is allocated and the first // entry points to its composition. } kk_yield_t; - -extern kk_ptr_t kk_evv_empty_singleton; - // The thread local context. // The fields `yielding`, `heap` and `evv` should come first for efficiency @@ -418,7 +413,7 @@ typedef struct kk_context_s { int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? const intptr_t heap_base; // mid point of the reserved heap address space (or 0 if the heap is not compressed) - kk_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector + kk_datatype_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector kk_yield_t yield; // inlined yield structure (for efficiency) int32_t marker_unique; // unique marker generation kk_block_t* delayed_free; // list of blocks that still need to be freed @@ -467,6 +462,7 @@ static inline kk_decl_pure bool kk_yielding_final(const kk_context_t* ctx) { return (ctx->yielding == KK_YIELD_FINAL); } + // Get a thread local marker unique number >= 1. static inline int32_t kk_marker_unique(kk_context_t* ctx) { int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; @@ -479,6 +475,8 @@ kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ); kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ); kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); +kk_decl_export kk_datatype_ptr_t kk_evv_empty_singleton(kk_context_t* ctx); + /*-------------------------------------------------------------------------------------- Allocation @@ -887,6 +885,13 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define kk_constructor_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_base._block).,n,ctx)) #define kk_constructor_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_base._block),x)) +#define kk_base_type_unbox_as_assert(tp,b,tag,ctx) (kk_block_as(tp,kk_block_unbox(b,tag,ctx))) +#define kk_base_type_unbox_as(tp,b,ctx) ((tp)kk_base_type_as(tp,kk_ptr_unbox(b,ctx),ctx)) +#define kk_base_type_box(b,ctx) (kk_block_box(&(b)->_block,ctx)) + +#define kk_constructor_unbox_as(tp,b,tag,ctx) (kk_base_type_unbox_as_assert(tp,b,tag,ctx)) +#define kk_constructor_box(b,ctx) (kk_base_type_box(&(b)->_base),ctx) + /*---------------------------------------------------------------------- @@ -921,7 +926,6 @@ static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { kk_assert_internal(extra_shift >= 0); - kk_assert_internal((i & KK_TAG_MASK) == 0); kk_assert_internal(i >= (KK_INTF_BOX_MIN / (KK_IF(1)< 0); - kk_block_dropn(kk_basetype_as_ptr(b,ctx), scan_fsize, ctx); -} - -static inline kk_basetype_t kk_basetype_dup_assert(kk_basetype_t b, kk_tag_t t, kk_context_t* ctx) { - kk_unused_internal(t); - kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); - return kk_basetype_dup(b, ctx); -} - -static inline void kk_basetype_drop_assert(kk_basetype_t b, kk_tag_t t, kk_context_t* ctx) { - kk_unused_internal(t); - kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); - kk_basetype_drop(b, ctx); -} - -static inline kk_reuse_t kk_basetype_dropn_reuse(kk_basetype_t b, kk_ssize_t scan_fsize, kk_context_t* ctx) { - kk_assert_internal(kk_basetype_is_ptr(b)); - return kk_block_dropn_reuse(kk_basetype_as_ptr(b,ctx), scan_fsize, ctx); -} - -static inline kk_reuse_t kk_basetype_reuse(kk_basetype_t b, kk_context_t* ctx) { - return kk_basetype_as_ptr(b,ctx); -} - -static inline void kk_basetype_free(kk_basetype_t b, kk_context_t* ctx) { - kk_free(kk_basetype_as_ptr(b,ctx), ctx); -} - -static inline void kk_basetype_decref(kk_basetype_t b, kk_context_t* ctx) { - kk_assert_internal(kk_basetype_is_ptr(b)); - kk_block_decref(kk_basetype_as_ptr(b,ctx), ctx); -} - -#define kk_basetype_from_base(b,ctx) (kk_basetype_from_ptr(&(b)->_block,ctx)) -#define kk_basetype_from_constructor(b,ctx) (kk_basetype_from_base(&(b)->_base,ctx)) -#define kk_basetype_as(tp,v,ctx) (kk_block_as(tp,kk_basetype_as_ptr(v,ctx))) -#define kk_basetype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_basetype_as_ptr(v,ctx),tag)) -#define kk_basetype_alloc(struct_tp,scan_fsize,tag,ctx) (kk_basetype_from_ptr(kk_block_alloc(kk_ssizeof(struct_tp),scan_fsize,tag,ctx),ctx)) -#define kk_basetype_dup_as(tp,v,ctx) (kk_basetype_dup(v,ctx)) -#define kk_basetype_null { _kk_make_value(0) } - -static inline bool kk_basetype_is_null(kk_basetype_t b) { - return kk_is_value(b.bbox); -} - -static inline kk_basetype_t kk_basetype_unbox(kk_box_t bx) { - kk_basetype_t b = { bx.box }; - return b; -} - -static inline kk_basetype_t kk_basetype_unbox_assert(kk_box_t bx, kk_tag_t t, kk_context_t* ctx) { - kk_unused_internal(ctx); - kk_basetype_t b = { bx.box }; - kk_assert_internal(kk_basetype_has_tag(b, t, ctx)); - return b; -} - -static inline kk_box_t kk_basetype_box(kk_basetype_t b) { - kk_box_t bx = { b.bbox }; - return bx; -} - - -#define kk_basetype_unbox_as_assert(tp,b,tag,ctx) (kk_basetype_as_assert(tp,kk_basetype_unbox(b),tag,ctx)) -#define kk_basetype_unbox_as(tp,b,ctx) ((tp)kk_basetype_as(tp,kk_basetype_unbox(b),ctx)) - -#define kk_constructor_unbox_as(tp,b,tag) (kk_basetype_unbox_as_assert(tp,b,tag)) -#define kk_constructor_box(b) (kk_basetype_box(&(b)->_base)) /*---------------------------------------------------------------------- @@ -1089,22 +973,32 @@ static inline kk_decl_const kk_block_t* kk_datatype_as_ptr(kk_datatype_t d, kk_c return kk_ptr_decode(d.dbox,ctx); } +static inline kk_decl_pure kk_tag_t kk_datatype_ptr_tag(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return kk_block_tag(kk_datatype_as_ptr(d, ctx)); +} + static inline kk_decl_pure kk_tag_t kk_datatype_tag(kk_datatype_t d, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return kk_block_tag(kk_datatype_as_ptr(d,ctx)); + return kk_datatype_ptr_tag(d, ctx); } else { return (kk_tag_t)kk_intf_decode(d.dbox,1); } } +static inline kk_decl_pure bool kk_datatype_ptr_has_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return (kk_block_tag(kk_datatype_as_ptr(d, ctx)) == t); +} + static inline kk_decl_pure bool kk_datatype_has_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return (kk_block_tag(kk_datatype_as_ptr(d,ctx)) == t); + return kk_datatype_ptr_has_tag(d, t, ctx); } else { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize ? + return (d.dbox == kk_datatype_from_tag(t).dbox); } } @@ -1113,45 +1007,77 @@ static inline kk_decl_pure bool kk_datatype_has_ptr_tag(kk_datatype_t d, kk_tag_ } static inline kk_decl_pure bool kk_datatype_has_singleton_tag(kk_datatype_t d, kk_tag_t t) { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize ? + return (d.dbox == kk_datatype_from_tag(t).dbox); } -static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d, kk_context_t* ctx) { +static inline bool kk_decl_pure kk_datatype_ptr_is_unique(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); //return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d))); return kk_block_is_unique(kk_datatype_as_ptr(d,ctx)); } +static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d, kk_context_t* ctx) { + return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d,ctx))); +} + +static inline kk_datatype_t kk_datatype_ptr_dup(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_block_dup(kk_datatype_as_ptr(d, ctx)); + return d; +} + + static inline kk_datatype_t kk_datatype_dup(kk_datatype_t d, kk_context_t* ctx) { - if (kk_datatype_is_ptr(d)) { kk_block_dup(kk_datatype_as_ptr(d,ctx)); } + if (kk_datatype_is_ptr(d)) { + kk_datatype_ptr_dup(d,ctx); + } return d; } +static inline void kk_datatype_ptr_drop(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_block_drop(kk_datatype_as_ptr(d, ctx), ctx); +} + static inline void kk_datatype_drop(kk_datatype_t d, kk_context_t* ctx) { - if (kk_datatype_is_ptr(d)) { kk_block_drop(kk_datatype_as_ptr(d,ctx), ctx); } + if (kk_datatype_is_ptr(d)) { + kk_datatype_ptr_drop(d, ctx); + } } -static inline void kk_datatype_dropn(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { +static inline void kk_datatype_ptr_dropn(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); kk_assert_internal(scan_fsize > 0); kk_block_dropn(kk_datatype_as_ptr(d,ctx), scan_fsize, ctx); } +static inline kk_datatype_t kk_datatype_ptr_dup_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(t); + kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); + return kk_datatype_ptr_dup(d, ctx); +} + static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); return kk_datatype_dup(d, ctx); } +static inline void kk_datatype_ptr_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(t); + kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); + kk_datatype_ptr_drop(d, ctx); +} + static inline void kk_datatype_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); kk_datatype_drop(d, ctx); } -static inline kk_reuse_t kk_datatype_dropn_reuse(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { +static inline kk_reuse_t kk_datatype_ptr_dropn_reuse(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - if kk_unlikely(kk_datatype_is_singleton(d)) { + if kk_unlikely(kk_datatype_is_singleton(d)) { // todo: why is this test here? return kk_reuse_null; } else { @@ -1159,18 +1085,15 @@ static inline kk_reuse_t kk_datatype_dropn_reuse(kk_datatype_t d, kk_ssize_t sca } } -static inline kk_reuse_t kk_datatype_reuse(kk_datatype_t d, kk_context_t* ctx) { - kk_assert_internal(!kk_datatype_is_singleton(d)); +static inline kk_reuse_t kk_datatype_ptr_reuse(kk_datatype_t d, kk_context_t* ctx) { return kk_datatype_as_ptr(d,ctx); } -static inline void kk_datatype_free(kk_datatype_t d, kk_context_t* ctx) { - kk_assert_internal(kk_datatype_is_ptr(d)); +static inline void kk_datatype_ptr_free(kk_datatype_t d, kk_context_t* ctx) { kk_free(kk_datatype_as_ptr(d,ctx), ctx); } -static inline void kk_datatype_decref(kk_datatype_t d, kk_context_t* ctx) { - kk_assert_internal(kk_datatype_is_ptr(d)); +static inline void kk_datatype_ptr_decref(kk_datatype_t d, kk_context_t* ctx) { kk_block_decref(kk_datatype_as_ptr(d,ctx), ctx); } @@ -1180,16 +1103,50 @@ static inline void kk_datatype_decref(kk_datatype_t d, kk_context_t* ctx) { #define kk_datatype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_datatype_as_ptr(v,ctx),tag)) +#define kk_datatype_null_init { (kk_intb_t)KK_TAG_VALUE } + +static inline kk_datatype_t kk_datatype_null(void) { + kk_datatype_t d = kk_datatype_null_init; + return d; +} + +static inline bool kk_datatype_is_null(kk_datatype_t d) { + return kk_datatype_eq(d, kk_datatype_null()); +} + static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { kk_datatype_t d = { b.box }; return d; } +static inline kk_datatype_t kk_datatype_ptr_unbox(kk_box_t b) { + kk_datatype_t d = { b.box }; + kk_assert_internal(kk_datatype_is_ptr(d)); + return d; +} + static inline kk_box_t kk_datatype_box(kk_datatype_t d) { kk_box_t b = { d.dbox }; return b; } +static inline kk_box_t kk_datatype_ptr_box(kk_datatype_t d) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_box_t b = { d.dbox }; + return b; +} + +static inline kk_datatype_t kk_datatype_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_datatype_t d = kk_datatype_unbox(b); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return d; +} + +static inline kk_datatype_t kk_datatype_ptr_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_datatype_t d = kk_datatype_ptr_unbox(b); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return d; +} /* #define kk_define_static_datatype(decl,kk_struct_tp,name,tag) \ @@ -1368,23 +1325,24 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { Functions --------------------------------------------------------------------------------------*/ -#define kk_function_as(tp,fun,ctx) kk_basetype_as_assert(tp,fun,KK_TAG_FUNCTION,ctx) +#define kk_function_as(tp,fun,ctx) kk_datatype_as_assert(tp,fun,KK_TAG_FUNCTION,ctx) #define kk_function_alloc_as(tp,scan_fsize,ctx) kk_block_alloc_as(tp,scan_fsize,KK_TAG_FUNCTION,ctx) -#define kk_function_call(restp,argtps,f,args,ctx) ((restp(*)argtps)(kk_kkfun_ptr_unbox(kk_basetype_as(struct kk_function_s*,f,ctx)->fun,ctx)))args +#define kk_function_call(restp,argtps,f,args,ctx) ((restp(*)argtps)(kk_kkfun_ptr_unbox(kk_datatype_as_assert(struct kk_function_s*,f,KK_TAG_FUNCTION,ctx)->fun,ctx)))args #if (KK_COMPRESS==0) #define kk_define_static_function(name,cfun,ctx) \ - static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, kk_box_null_init }; /* must be box_null */ \ + static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, { kk_box_null_init } }; /* must be box_null */ \ struct kk_function_s* const _##name = &_static_##name; \ - kk_function_t name = { (intptr_t)_##name }; \ + kk_function_t name = { (kk_intb_t)_##name }; \ if (kk_box_eq(_##name->fun,kk_box_null())) { _##name->fun = kk_kkfun_ptr_box(&cfun,ctx); } // initialize on demand we can encode the field */ #else // for a compressed heap, allocate static functions once in the heap on demand; these are never deallocated #define kk_define_static_function(name,cfun,ctx) \ - static kk_function_t name = kk_basetype_null; \ - if (kk_basetype_is_null(name)) { \ - name = kk_basetype_alloc(struct kk_function_s, 1, KK_TAG_FUNCTION, ctx); \ - kk_basetype_as(struct kk_function_s*, name, ctx)->fun = kk_kkfun_ptr_box(&cfun, ctx); \ + static kk_function_t name = kk_datatype_null_init; \ + if (kk_datatype_is_null(name)) { \ + struct kk_function_s* _fun = kk_block_alloc_as(struct kk_function_s, 1, KK_TAG_FUNCTION, ctx); \ + _fun->fun = kk_kkfun_ptr_box(&cfun, ctx); \ + name = kk_datatype_from_base(_fun,ctx); \ } #endif @@ -1393,28 +1351,26 @@ kk_function_t kk_function_id(kk_context_t* ctx); kk_function_t kk_function_null(kk_context_t* ctx); bool kk_function_is_null(kk_function_t f, kk_context_t* ctx); -static inline kk_decl_pure kk_function_t kk_function_unbox_assert(kk_box_t v, kk_context_t* ctx) { - return kk_basetype_unbox_assert(v, KK_TAG_FUNCTION, ctx); -} - -static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v) { - return kk_basetype_unbox(v); +static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_unbox(v); } -static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d) { - return kk_basetype_box(d); +static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_box(d); } static inline kk_decl_pure bool kk_function_is_unique(kk_function_t f, kk_context_t* ctx) { - return kk_basetype_is_unique(f,ctx); + return kk_datatype_ptr_is_unique(f,ctx); } static inline void kk_function_drop(kk_function_t f, kk_context_t* ctx) { - kk_basetype_drop_assert(f, KK_TAG_FUNCTION, ctx); + kk_datatype_ptr_drop_assert(f, KK_TAG_FUNCTION, ctx); } static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) { - return kk_basetype_dup_assert(f, KK_TAG_FUNCTION, ctx); + return kk_datatype_ptr_dup_assert(f, KK_TAG_FUNCTION, ctx); } @@ -1528,38 +1484,38 @@ struct kk_ref_s { kk_block_t _block; _Atomic(kk_intb_t) value; }; -typedef kk_basetype_t kk_ref_t; +typedef kk_datatype_ptr_t kk_ref_t; kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx); kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value); -kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(struct kk_ref_s* r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); +kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { kk_unused(ctx); - return kk_basetype_box(r); + return kk_datatype_ptr_box(r); } static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); - return kk_basetype_unbox_assert(b, KK_TAG_REF, ctx); + return kk_datatype_ptr_unbox_assert(b, KK_TAG_REF, ctx); } static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { - kk_basetype_drop_assert(r, KK_TAG_REF, ctx); + kk_datatype_ptr_drop_assert(r, KK_TAG_REF, ctx); } static inline kk_ref_t kk_ref_dup(kk_ref_t r, kk_context_t* ctx) { - return kk_basetype_dup_assert(r, KK_TAG_REF, ctx); + return kk_datatype_ptr_dup_assert(r, KK_TAG_REF, ctx); } static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { struct kk_ref_s* r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); kk_atomic_store_relaxed(&r->value,value.box); - return kk_basetype_from_base(r,ctx); + return kk_datatype_from_base(r,ctx); } static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { - struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); @@ -1574,7 +1530,7 @@ static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { } static inline kk_box_t kk_ref_swap_borrow(kk_ref_t _r, kk_box_t value, kk_context_t* ctx) { - struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); @@ -1627,8 +1583,8 @@ kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t ch // use a macro as `x` can be a datatype or direct pointer; update the field_idx with the field // index + 1 that is along the context path, and return `x` as is. -#define kk_ctail_set_context_path(as_tp,x,field_offset) \ - (kk_constructor_field_idx_set( as_tp(x), 1 + ((field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)) ), x) +#define kk_ctail_set_context_path(as_tp,x,field_offset,ctx) \ + (kk_constructor_field_idx_set( as_tp(x,ctx), 1 + ((field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)) ), x) #endif diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 5e6bd9e9c..8f5be3d9d 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -115,6 +115,15 @@ static inline bool kk_box_is_any(kk_box_t b) { return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b,kk_get_context()), KK_TAG_BOX_ANY)); } +static inline kk_box_t kk_box_from_potential_null_ptr(kk_block_t* p, kk_context_t* ctx) { + if (p == NULL) return kk_box_null(); + else return kk_box_from_ptr(p,ctx); +} + +static inline kk_block_t* kk_box_to_potential_null_ptr(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_null(b)) return NULL; + else return kk_box_to_ptr(b, ctx); +} /*---------------------------------------------------------------- Box pointers and kk_intf_t @@ -275,6 +284,8 @@ static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag, k return b; } +#define kk_block_unbox_as(tp,v,tag,ctx) kk_block_as(tp,kk_block_unbox(v,tag,ctx)) + static inline kk_box_t kk_block_box(kk_block_t* b, kk_context_t* ctx) { return kk_ptr_box(b, ctx); } @@ -321,10 +332,10 @@ typedef struct kk_boxed_value_s { const size_t kk__max_scan_fsize = sizeof(tp)/sizeof(kk_box_t); \ kk_box_t* _fields = (kk_box_t*)(&x); \ for (size_t i = 0; i < kk__max_scan_fsize; i++) { _fields[i] = kk_box_any(ctx); } \ - kk_block_decref(kk_ptr_unbox(box,ctx),ctx); \ + kk_block_decref(kk_block_unbox(box,KK_TAG_BOX_ANY,ctx),ctx); \ } \ else { \ - p = kk_block_as(kk_boxed_value_t, kk_block_unbox(box, KK_TAG_BOX, ctx)); \ + p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ } \ } while(0) @@ -334,14 +345,14 @@ typedef struct kk_boxed_value_s { kk_boxed_value_t p = kk_block_assert(kk_boxed_value_t, kk_block_alloc(sizeof(kk_block_t) + sizeof(tp), scan_fsize, KK_TAG_BOX, ctx), KK_TAG_BOX); \ const tp valx = val; /* ensure we can take the address */ \ memcpy(&p->data,&valx,sizeof(tp)); /* avoid aliasing warning: *((tp*)(&p->data)) = val; */ \ - x = kk_block_box(&p->_block,ctx); \ + x = kk_base_type_box(p,ctx); \ } while(0) // `box_any` is used to return when yielding // (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) static inline kk_box_t kk_box_any(kk_context_t* ctx) { - kk_basetype_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); - return kk_basetype_box(ctx->kk_box_any); + kk_datatype_ptr_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); + return kk_datatype_ptr_box(ctx->kk_box_any); } diff --git a/kklib/include/kklib/bytes.h b/kklib/include/kklib/bytes.h index 1d0d05368..d709de5f6 100644 --- a/kklib/include/kklib/bytes.h +++ b/kklib/include/kklib/bytes.h @@ -180,7 +180,7 @@ static inline bool kk_bytes_is_empty(kk_bytes_t s, kk_context_t* ctx) { } static inline kk_bytes_t kk_bytes_copy(kk_bytes_t b, kk_context_t* ctx) { - if (kk_datatype_is_singleton(b) || kk_datatype_is_unique(b,ctx)) { + if (kk_datatype_is_singleton(b) || kk_datatype_ptr_is_unique(b,ctx)) { return b; } else { @@ -237,7 +237,7 @@ static inline int kk_memcmp(const void* s, const void* t, kk_ssize_t len) { } -kk_decl_export kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t str, kk_bytes_t pattern); +kk_decl_export kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t str, kk_bytes_t pattern, kk_context_t* ctx); kk_decl_export kk_bytes_t kk_bytes_cat(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx); kk_decl_export kk_bytes_t kk_bytes_cat_from_buf(kk_bytes_t s1, kk_ssize_t len2, const uint8_t* buf2, kk_context_t* ctx); diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 2b0d8f65e..53d10fa9d 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -157,8 +157,12 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. #define KK_INT_USE_RENO 4 // use range extended overflow arithmetic #ifndef KK_INT_ARITHMETIC +#if (KK_INTF_SIZE <= 4) && defined(__GNUC__) +#define KK_INT_ARITHMETIC KK_INT_USE_OVF +#else #define KK_INT_ARITHMETIC KK_INT_USE_SOFA #endif +#endif #ifndef KK_INT_TAG #define KK_INT_TAG (1) diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index d233da07e..f67ab1eae 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -228,18 +228,22 @@ // Define size of intptr_t #if INTPTR_MAX == INT64_MAX # define KK_INTPTR_SIZE 8 +# define KK_INTPTR_SHIFT 3 # define KK_IP(i) KK_I64(i) # define KK_UP(i) KK_U64(i) #elif INTPTR_MAX == INT32_MAX # define KK_INTPTR_SIZE 4 +# define KK_INTPTR_SHIFT 2 # define KK_IP(i) KK_I32(i) # define KK_UP(i) KK_U32(i) #elif INTPTR_MAX == INT16_MAX # define KK_INTPTR_SIZE 2 +# define KK_INTPTR_SHIFT 1 # define KK_IP(i) i # define KK_UP(i) i #elif INTPTR_MAX > INT64_MAX // assume 128-bit # define KK_INTPTR_SIZE 16 +# define KK_INTPTR_SHIFT 4 # define KK_IP(i) KK_I64(i) # define KK_UP(i) KK_U64(i) #else diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index 184ba84fc..d2659d989 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -125,10 +125,10 @@ static inline kk_string_t kk_string_empty() { #define kk_declare_string_literal(decl,name,len,chars) \ static kk_ssize_t _static_len_##name = len; \ static const char* _static_##name = chars; \ - decl kk_string_t name = { 0 }; + decl kk_string_t name = { kk_datatype_null_init }; #define kk_init_string_literal(name,ctx) \ - if (name.bytes.dbox == 0) { name = kk_string_alloc_from_utf8n(_static_len_##name, _static_##name, ctx); } + if (kk_datatype_is_null(name.bytes)) { name = kk_string_alloc_from_utf8n(_static_len_##name, _static_##name, ctx); } #define kk_define_string_literal(decl,name,len,chars,ctx) \ kk_declare_string_literal(decl,name,len,chars) \ diff --git a/kklib/src/box.c b/kklib/src/box.c index d2d4bebdc..473920254 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -189,7 +189,7 @@ kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx) { } void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx) { - kk_cptr_raw_t raw = kk_basetype_unbox_as_assert(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); + kk_cptr_raw_t raw = kk_block_unbox_as(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); return raw->cptr; } diff --git a/kklib/src/bytes.c b/kklib/src/bytes.c index f6c13f693..54ff73446 100644 --- a/kklib/src/bytes.c +++ b/kklib/src/bytes.c @@ -58,9 +58,9 @@ kk_bytes_t kk_bytes_adjust_length(kk_bytes_t b, kk_ssize_t newlen, kk_context_t* return b; } else if (len > newlen && (3*(len/4)) < newlen && // 0.75*len < newlen < len: update length in place if we can - kk_datatype_is_unique(b,ctx) && kk_datatype_has_tag(b, KK_TAG_BYTES, ctx)) { + kk_datatype_ptr_is_unique(b,ctx) && kk_datatype_ptr_has_tag(b, KK_TAG_BYTES, ctx)) { // length in place - kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES,ctx) && kk_datatype_is_unique(b,ctx)); + kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES,ctx) && kk_datatype_ptr_is_unique(b,ctx)); kk_bytes_normal_t nb = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES, ctx); nb->length = newlen; nb->buf[newlen] = 0; @@ -247,7 +247,7 @@ kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, const uint8_t* const pend = p + plen; // if unique s && |rep| == |pat|, update in-place // TODO: if unique s & |rep| <= |pat|, maybe update in-place if not too much waste? - if (kk_datatype_is_unique(s,ctx) && ppat_len == prep_len) { + if (kk_datatype_ptr_is_unique(s,ctx) && ppat_len == prep_len) { kk_ssize_t count = 0; while (count < n && p < pend) { const uint8_t* r = kk_memmem(p, pend - p, ppat, ppat_len); diff --git a/kklib/src/init.c b/kklib/src/init.c index 1a512f50d..640fb46b7 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -38,7 +38,7 @@ kk_function_t kk_function_null(kk_context_t* ctx) { } bool kk_function_is_null(kk_function_t f, kk_context_t* ctx) { kk_function_t fnull = kk_function_null(ctx); - bool eq = kk_basetype_eq(f, fnull); + bool eq = kk_datatype_eq(f, fnull); kk_function_drop(fnull, ctx); return eq; } @@ -197,34 +197,67 @@ static kk_decl_thread kk_context_t* context; static struct { kk_block_t _block; kk_integer_t cfc; } kk_evv_empty_static = { { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UB(0))^0x02) /*==-1 smallint*/} }; -kk_ptr_t kk_evv_empty_singleton = &kk_evv_empty_static._block; + +struct kk_evv_s { + kk_block_t _block; + kk_integer_t cfc; +}; + +kk_datatype_ptr_t kk_evv_empty_singleton(kk_context_t* ctx) { + static struct kk_evv_s* evv = NULL; + if (evv == NULL) { + evv = kk_block_alloc_as(struct kk_evv_s, 1, KK_TAG_EVV_VECTOR, ctx); + evv->cfc = kk_integer_from_small(-1); + } + kk_base_type_dup_as(struct kk_evv_s*, evv); + return kk_datatype_from_base(evv, ctx); +} + // Get the thread local context (also initializes on demand) kk_context_t* kk_get_context(void) { kk_context_t* ctx = context; if (ctx!=NULL) return ctx; kklib_init(); -#ifdef KK_MIMALLOC - mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); +#if KK_INTF_SIZE==4 && KK_COMPRESS && defined(KK_MIMALLOC) +#if defined(KK_MIMALLOC) + mi_arena_id_t arena; + kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8); // +KK_BOX_PTR_SHIFT); + int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); + if (err != 0) { + kk_fatal_error(err, "unable to reserve the initial heap"); +} + mi_heap_t* heap = mi_heap_new_in_arena(arena); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); kk_assign_const(kk_heap_t,ctx->heap) = heap; + size_t arena_size; + void* arena_base = mi_arena_area(arena, &arena_size); + kk_assign_const(intptr_t,ctx->heap_base) = (intptr_t)arena_base + (intptr_t)(arena_size / 2); +#else +#error "can only use compressed heaps with the mimalloc allocator enabled" +#endif +#elif defined(KK_MIMALLOC) + mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); + ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); + kk_assign_const(kk_heap_t, ctx->heap) = heap; #else - ctx = (kk_context_t*)kk_zalloc(sizeof(kk_context_t),NULL); + ctx = (kk_context_t*)kk_zalloc(sizeof(kk_context_t), NULL); #endif - ctx->evv = kk_block_dup(kk_evv_empty_singleton); ctx->thread_id = (size_t)(&context); ctx->unique = kk_integer_one; context = ctx; - ctx->kk_box_any = kk_basetype_alloc(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); - kk_basetype_as(struct kk_box_any_s*,ctx->kk_box_any,ctx)->_unused = kk_integer_zero; + struct kk_box_any_s* boxany = kk_block_alloc_as(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); + boxany->_unused = kk_integer_zero; + ctx->kk_box_any = kk_datatype_from_base(boxany, ctx); + ctx->evv = kk_evv_empty_singleton(ctx); // todo: register a thread_done function to release the context on thread terminatation. return ctx; } void kk_free_context(void) { if (context != NULL) { - kk_block_drop(context->evv, context); - kk_basetype_free(context->kk_box_any,context); + kk_datatype_ptr_drop(context->evv, context); + kk_datatype_ptr_free(context->kk_box_any,context); // kk_basetype_drop_assert(context->kk_box_any, KK_TAG_BOX_ANY, context); // TODO: process delayed_free #ifdef KK_MIMALLOC diff --git a/kklib/src/integer.c b/kklib/src/integer.c index 84872672f..2bde30aa3 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -343,7 +343,7 @@ static kk_bigint_t* bigint_from_int(kk_intx_t i, kk_context_t* ctx) { u = (kk_uintx_t)i; } else if (i == KK_INTX_MIN) { - u = (KK_UINTX_MAX/2) + KK_UX(1); + u = ((KK_UINTX_MAX)/2) + KK_UX(1); } else { u = (kk_uintx_t)(-i); diff --git a/kklib/src/os.c b/kklib/src/os.c index dc3918e47..e3305feb8 100644 --- a/kklib/src/os.c +++ b/kklib/src/os.c @@ -979,7 +979,7 @@ kk_string_t kk_os_app_path(kk_context_t* ctx) { kk_string_t kk_os_app_path(kk_context_t* ctx) { kk_string_t s = kk_os_realpath(kk_string_alloc_dup_valid_utf8(KK_PROC_SELF,ctx),ctx); - if (strcmp(kk_string_cbuf_borrow(s,NULL), KK_PROC_SELF)==0) { + if (strcmp(kk_string_cbuf_borrow(s,NULL,ctx), KK_PROC_SELF)==0) { // failed? try generic search kk_string_drop(s, ctx); return kk_os_app_path_generic(ctx); diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 713d3e5be..ff10c7dc9 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -328,7 +328,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t // go down into the child if (i < scan_fsize) { // save our progress to continue here later (when moving up along the parent chain) - kk_block_field_set(b, 0, kk_box_from_ptr(parent,ctx)); // set parent (use low-level box as parent could be NULL) + kk_block_field_set(b, 0, kk_box_from_potential_null_ptr(parent,ctx)); // set parent (use low-level box as parent could be NULL) kk_block_field_idx_set(b,i); parent = b; } @@ -349,7 +349,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t // move_up: if (parent != NULL) { b = parent; - parent = kk_box_to_ptr( kk_block_field(parent, 0), ctx ); // low-level unbox as it can be NULL + parent = kk_box_to_potential_null_ptr( kk_block_field(parent, 0), ctx ); // low-level unbox as it can be NULL scan_fsize = b->header.scan_fsize; i = kk_block_field_idx(b); kk_assert_internal(i < scan_fsize); @@ -642,7 +642,7 @@ static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context if (child != NULL) { // visit the child, but remember our state and link back to the parent // note: we cannot optimize for the last child as in freeing as we need to restore all parent fields - kk_block_field_set(b, i - 1, kk_box_from_ptr(parent,ctx)); // low-level box as parent can be NULL + kk_block_field_set(b, i - 1, kk_box_from_potential_null_ptr(parent,ctx)); // low-level box as parent can be NULL kk_block_mark_idx_set(b, i); parent = b; b = child; @@ -659,7 +659,7 @@ static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context i = kk_block_mark_idx(parent); scan_fsize = parent->header.scan_fsize; kk_assert_internal(i > 0 && i <= scan_fsize); - kk_block_t* pparent = kk_box_to_ptr( kk_block_field(parent, i-1), ctx ); // low-level unbox on parent + kk_block_t* pparent = kk_box_to_potential_null_ptr( kk_block_field(parent, i-1), ctx ); // low-level unbox on parent kk_block_field_set(parent, i-1, kk_ptr_box(b,ctx)); // restore original pointer b = parent; parent = pparent; diff --git a/kklib/src/thread.c b/kklib/src/thread.c index 51413e1da..716c31455 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -361,7 +361,7 @@ static void kk_task_group_init(void) { kk_promise_t kk_task_schedule( kk_function_t fun, kk_context_t* ctx ) { pthread_once( &task_group_once, &kk_task_group_init ); kk_assert(task_group != NULL); - kk_block_mark_shared( kk_basetype_as_ptr(fun,ctx), ctx); // mark everything reachable from the task as shared + kk_block_mark_shared( kk_datatype_as_ptr(fun,ctx), ctx); // mark everything reachable from the task as shared if (ctx->task_group == NULL) { ctx->task_group = task_group; // let main thread participate instead of blocking on a promise.get } diff --git a/kklib/src/vector.c b/kklib/src/vector.c index ff7ae5ac8..925fd957f 100644 --- a/kklib/src/vector.c +++ b/kklib/src/vector.c @@ -51,7 +51,7 @@ kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx) { } kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t _r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { - struct kk_ref_s* r = kk_basetype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); diff --git a/kklib/test/main.c b/kklib/test/main.c index 13a867687..8fe0510db 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -78,11 +78,11 @@ static void testx(const char* name, iop* op, xop* opx, kk_intf_t i, kk_intf_t j, kk_integer_t y = _kk_new_integer(j); intptr_t k = _kk_integer_value(op(x, y, ctx)); intptr_t expect = opx(i, j, ctx); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", i, name, j, k, (k == expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", (intptr_t)i, name, (intptr_t)j, k, (k == expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); } static void testb(const char* name, iop* op, kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { kk_integer_t k = (op(x, y, ctx)); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", _kk_integer_value(x), name, _kk_integer_value(y), _kk_integer_value(k), (_kk_integer_value(k) == _kk_integer_value(expect) ? "ok" : "FAIL"), _kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", (intptr_t)_kk_integer_value(x), name, (intptr_t)_kk_integer_value(y), (intptr_t)_kk_integer_value(k), (_kk_integer_value(k) == _kk_integer_value(expect) ? "ok" : "FAIL"), (intptr_t)_kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); } static void test_op(const char* name, iop* op, xop* opx, kk_context_t* ctx) { testx(name, op, opx, KK_SMALLINT_MAX, 1, ctx); @@ -428,7 +428,7 @@ static void test_popcount(void) { static void test_box_double(double dx, kk_context_t* ctx) { kk_box_t bx = kk_double_box(dx, ctx); double e = kk_double_unbox(bx, ctx); - printf("value: %.20e, box-unbox to: %.20e, box: 0x%016zx\n", dx, e, bx.box); + printf("value: %.20e, box-unbox to: %.20e, box: 0x%016zx\n", dx, e, (intptr_t)bx.box); assert(e == dx || (isnan(e) && isnan(dx))); } diff --git a/lib/std/core.kk b/lib/std/core.kk index 1c8578ff5..d5116a6a9 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1013,7 +1013,7 @@ pub fun is-neg(i : int ) : bool i.sign == Lt pub inline extern sign( ^i : int ) : order - c inline "kk_int_as_order(kk_integer_signum_borrow(#1),kk_context())" + c inline "kk_int_as_order(kk_integer_signum_borrow(#1,kk_context()),kk_context())" cs "Primitive.IntSign" js "$std_core._int_sign" @@ -1822,7 +1822,7 @@ pub inline extern trim-right( s : string ) : string // Return the element at position `index` in vector `v` without bounds check! inline extern unsafe-idx( ^v : vector, index : ssize_t ) : total a - c inline "kk_vector_at_borrow(#1,#2)" + c "kk_vector_at_borrow" cs inline "(#1)[#2]" js inline "(#1)[#2]" @@ -1852,7 +1852,7 @@ pub fun length( ^v : vector ) : int v.lengthz.int inline extern lengthz( ^v : vector ) : ssize_t - c inline "kk_vector_len_borrow(#1)" + c "kk_vector_len_borrow" cs inline "((#1).Length)" js inline "((#1).length)" @@ -2331,20 +2331,20 @@ pub type null // Unsafe: transform any type to a `null` type; used internally by the compiler. pub extern ".null-any"(x : a) : null - c inline "((#1).box == kk_box_null.box ? kk_datatype_from_ptr(NULL) : kk_datatype_unbox(#1))" + c inline "(kk_box_is_null(#1) ? kk_datatype_null() : kk_datatype_unbox(#1))" cs inline "#1" js inline "(#1==null ? null : #1)" // undefined -> null // Transform a `:maybe` type to a `:null` type (using `null` for `Nothing`). pub extern null(x : maybe) : null - c inline "(kk_std_core_types__is_Nothing(#1) ? kk_datatype_from_ptr(NULL) : kk_datatype_unbox((#1)._cons.Just.value) /* kk_datatype_unbox(kk_datatype_unjust(#1,kk_context())) */ )" + c inline "(kk_std_core_types__is_Nothing(#1,kk_context()) ? kk_datatype_null() : kk_datatype_unbox((#1)._cons.Just.value) /* kk_datatype_unbox(kk_datatype_unjust(#1,kk_context())) */ )" cs inline "(#1.tag_ == __std_core._maybe_Tag.Nothing ? default(##1) : #1.@value)" js inline "(#1==null ? null : #1.value)" // Transform a `:null` type to a `:maybe` type. Note that it is not // always the case that `id(x) == maybe(null(x))` (e.g. when `x = Just(Nothing)`). pub extern maybe( n : null ) : maybe - c inline "(kk_datatype_as_ptr(#1) == NULL ? kk_std_core_types__new_Nothing(kk_context()) : kk_std_core_types__new_Just(kk_datatype_box(#1),kk_context()))" + c inline "(kk_datatype_is_null(#1) ? kk_std_core_types__new_Nothing(kk_context()) : kk_std_core_types__new_Just(kk_datatype_box(#1),kk_context()))" cs inline "(EqualityComparer<##1>.Default.Equals(#1,default(##1)) ? __std_core._maybe<##1>.Nothing_ : new __std_core._maybe<##1>(#1))" js inline "(#1==null ? $std_core_types.Nothing : $std_core_types.Just(#1))" @@ -2506,6 +2506,6 @@ pub alias value = a // Internal: used for value effects // TODO: revisit value effects codegen pub extern phantom() : a - c inline "kk_box_null" + c inline "kk_box_null()" inline "undefined" diff --git a/lib/std/core/core-inline.c b/lib/std/core/core-inline.c index 2cb830b26..a305ccd12 100644 --- a/lib/std/core/core-inline.c +++ b/lib/std/core/core-inline.c @@ -10,7 +10,7 @@ kk_std_core__list kk_vector_to_list(kk_vector_t v, kk_std_core__list tail, kk_context_t* ctx) { // todo: avoid boxed_dup if v is unique kk_ssize_t n; - kk_box_t* p = kk_vector_buf_borrow(v, &n); + kk_box_t* p = kk_vector_buf_borrow(v, &n, ctx); if (n <= 0) { kk_vector_drop(v,ctx); return tail; @@ -19,14 +19,14 @@ kk_std_core__list kk_vector_to_list(kk_vector_t v, kk_std_core__list tail, kk_co struct kk_std_core_Cons* cons = NULL; kk_std_core__list list = kk_std_core__new_Nil(ctx); for( kk_ssize_t i = 0; i < n; i++ ) { - kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,kk_box_dup(p[i]), nil, ctx); + kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,kk_box_dup(p[i],ctx), nil, ctx); if (cons==NULL) { list = hd; } else { cons->tail = hd; } - cons = kk_std_core__as_Cons(hd); + cons = kk_std_core__as_Cons(hd,ctx); } if (cons == NULL) { list = tail; } else { cons->tail = tail; } @@ -39,8 +39,8 @@ kk_vector_t kk_list_to_vector(kk_std_core__list xs, kk_context_t* ctx) { // find the length kk_ssize_t len = 0; kk_std_core__list ys = xs; - while (kk_std_core__is_Cons(ys)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys); + while (kk_std_core__is_Cons(ys,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys,ctx); len++; ys = cons->tail; } @@ -49,9 +49,9 @@ kk_vector_t kk_list_to_vector(kk_std_core__list xs, kk_context_t* ctx) { kk_vector_t v = kk_vector_alloc_uninit(len, &p, ctx); ys = xs; for( kk_ssize_t i = 0; i < len; i++) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys); + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys,ctx); ys = cons->tail; - p[i] = kk_box_dup(cons->head); + p[i] = kk_box_dup(cons->head,ctx); } kk_std_core__list_drop(xs,ctx); // todo: drop while visiting? return v; @@ -61,21 +61,21 @@ kk_vector_t kk_vector_init( kk_ssize_t n, kk_function_t init, kk_context_t* ctx) kk_box_t* p; kk_vector_t v = kk_vector_alloc_uninit(n, &p, ctx); for(kk_ssize_t i = 0; i < n; i++) { - kk_function_dup(init); - p[i] = kk_function_call(kk_box_t,(kk_function_t,kk_ssize_t,kk_context_t*),init,(init,i,ctx)); + kk_function_dup(init,ctx); + p[i] = kk_function_call(kk_box_t,(kk_function_t,kk_ssize_t,kk_context_t*),init,(init,i,ctx),ctx); } kk_function_drop(init,ctx); return v; } kk_box_t kk_main_console( kk_function_t action, kk_context_t* ctx ) { - return kk_function_call(kk_box_t,(kk_function_t,kk_unit_t,kk_context_t*),action,(action,kk_Unit,ctx)); + return kk_function_call(kk_box_t,(kk_function_t,kk_unit_t,kk_context_t*),action,(action,kk_Unit,ctx),ctx); } kk_std_core__list kk_string_to_list(kk_string_t s, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* p = kk_string_buf_borrow(s,&len); + const uint8_t* p = kk_string_buf_borrow(s,&len,ctx); const uint8_t* const end = p + len; kk_std_core__list nil = kk_std_core__new_Nil(ctx); kk_std_core__list list = nil; @@ -91,7 +91,7 @@ kk_std_core__list kk_string_to_list(kk_string_t s, kk_context_t* ctx) { else { list = cons; } - tl = kk_std_core__as_Cons(cons); + tl = kk_std_core__as_Cons(cons,ctx); } kk_string_drop(s,ctx); return list; @@ -102,8 +102,8 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { // find total UTF8 length kk_ssize_t len = 0; kk_std_core__list xs = cs; - while (kk_std_core__is_Cons(xs)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs); + while (kk_std_core__is_Cons(xs,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); len += kk_utf8_len(kk_char_unbox(cons->head,ctx)); xs = cons->tail; } @@ -111,21 +111,21 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { uint8_t* p; kk_string_t s = kk_unsafe_string_alloc_buf(len,&p,ctx); // must be initialized xs = cs; - while (kk_std_core__is_Cons(xs)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs); + while (kk_std_core__is_Cons(xs,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); kk_ssize_t count; kk_utf8_write( kk_char_unbox(cons->head,ctx), p, &count ); p += count; xs = cons->tail; } - kk_assert_internal(*p == 0 && (p - kk_string_buf_borrow(s,NULL)) == len); + kk_assert_internal(*p == 0 && (p - kk_string_buf_borrow(s,NULL,ctx)) == len); kk_std_core__list_drop(cs,ctx); // todo: drop while visiting? return s; } -static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, const uint8_t** sstart, const uint8_t** send) { +static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, const uint8_t** sstart, const uint8_t** send, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(sslice.str,&slen); + const uint8_t* s = kk_string_buf_borrow(sslice.str,&slen,ctx); *start = s + sslice.start; *end = s + sslice.start + sslice.len; if (sstart != NULL) *sstart = s; @@ -134,15 +134,15 @@ static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, cons kk_assert_internal(*end >= *start && *end <= s + slen); } -static inline void kk_sslice_start_end_borrow( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end) { - kk_sslice_start_end_borrowx(sslice,start,end,NULL,NULL); +static inline void kk_sslice_start_end_borrow( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, kk_context_t* ctx) { + kk_sslice_start_end_borrowx(sslice,start,end,NULL,NULL,ctx); } kk_integer_t kk_slice_count( kk_std_core__sslice sslice, kk_context_t* ctx ) { // TODO: optimize this by extending kk_string_count const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(sslice, &start, &end); + kk_sslice_start_end_borrow(sslice, &start, &end, ctx); kk_ssize_t count = 0; while( start < end && *start != 0 ) { const uint8_t* next = kk_utf8_next(start); @@ -156,9 +156,9 @@ kk_integer_t kk_slice_count( kk_std_core__sslice sslice, kk_context_t* ctx ) { kk_string_t kk_slice_to_string( kk_std_core__sslice sslice, kk_context_t* ctx ) { const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(sslice, &start, &end); + kk_sslice_start_end_borrow(sslice, &start, &end, ctx); // is it the full string? - if (sslice.start == 0 && sslice.len == kk_string_len_borrow(sslice.str)) { + if (sslice.start == 0 && sslice.len == kk_string_len_borrow(sslice.str,ctx)) { // TODO: drop sslice and dup sslice.str? return sslice.str; } @@ -172,22 +172,22 @@ kk_string_t kk_slice_to_string( kk_std_core__sslice sslice, kk_context_t* ctx ) kk_std_core__sslice kk_slice_first( kk_string_t str, kk_context_t* ctx ) { kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(str,&slen); + const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* next = (slen > 0 ? kk_utf8_next(s) : s); return kk_std_core__new_Sslice(str, 0, (next - s), ctx); } kk_std_core__sslice kk_slice_last( kk_string_t str, kk_context_t* ctx ) { kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(str,&slen); + const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* end = s + slen; const uint8_t* prev = (s==end ? s : kk_utf8_prev(end)); return kk_std_core__new_Sslice(str, (prev - s), (end - prev), ctx); } kk_std_core__sslice kk_slice_between( struct kk_std_core_Sslice slice1, struct kk_std_core_Sslice slice2, kk_context_t* ctx ) { - const uint8_t* s1 = kk_string_buf_borrow( slice1.str, NULL ); - const uint8_t* s2 = kk_string_buf_borrow( slice2.str, NULL ); + const uint8_t* s1 = kk_string_buf_borrow( slice1.str, NULL, ctx ); + const uint8_t* s2 = kk_string_buf_borrow( slice2.str, NULL, ctx ); if (s1 != s2) { kk_info_message("between: not equal slices: %p vs. %p\n", s1, s2); return kk_std_core__new_Sslice(kk_string_empty(), 0, -1, ctx); // invalid slice @@ -204,7 +204,7 @@ kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_cont } const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(slice, &start, &end); + kk_sslice_start_end_borrow(slice, &start, &end, ctx); kk_ssize_t clen; const kk_char_t c = kk_utf8_read(start,&clen); kk_assert_internal(clen > 0 && clen <= slice.len); @@ -221,7 +221,7 @@ struct kk_std_core_Sslice kk_slice_extend_borrow( struct kk_std_core_Sslice slic if (cnt==0 || (slice.len <= 0 && cnt<0)) return slice; const uint8_t* s0; const uint8_t* s1; - kk_sslice_start_end_borrow(slice,&s0,&s1); + kk_sslice_start_end_borrow(slice,&s0,&s1,ctx); const uint8_t* t = s1; if (cnt >= 0) { do { @@ -249,7 +249,7 @@ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice sli const uint8_t* s0; const uint8_t* s1; const uint8_t* send; - kk_sslice_start_end_borrowx(slice,&s0,&s1,&sstart,&send); + kk_sslice_start_end_borrowx(slice,&s0,&s1,&sstart,&send,ctx); // advance the start const uint8_t* t0 = s0; if (cnt >= 0) { @@ -287,8 +287,8 @@ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice sli /* Borrow iupto */ struct kk_std_core_Sslice kk_slice_common_prefix_borrow( kk_string_t str1, kk_string_t str2, kk_integer_t iupto, kk_context_t* ctx ) { - const uint8_t* s1 = kk_string_buf_borrow(str1,NULL); - const uint8_t* s2 = kk_string_buf_borrow(str2,NULL); + const uint8_t* s1 = kk_string_buf_borrow(str1,NULL,ctx); + const uint8_t* s2 = kk_string_buf_borrow(str2,NULL,ctx); kk_ssize_t upto = kk_integer_clamp_ssize_t_borrow(iupto,ctx); kk_ssize_t count; for(count = 0; count < upto && *s1 != 0 && *s2 != 0; count++, s1++, s2++ ) { @@ -329,7 +329,7 @@ kk_std_core__error kk_error_from_errno( int err, kk_context_t* ctx ) { kk_unit_t kk_assert_fail( kk_string_t msg, kk_context_t* ctx ) { - kk_fatal_error(EINVAL, "assertion failed: %s\n", kk_string_cbuf_borrow(msg,NULL)); + kk_fatal_error(EINVAL, "assertion failed: %s\n", kk_string_cbuf_borrow(msg,NULL,ctx)); kk_string_drop(msg,ctx); return kk_Unit; } \ No newline at end of file diff --git a/lib/std/core/core-inline.h b/lib/std/core/core-inline.h index d91ca36b6..9969ce8a1 100644 --- a/lib/std/core/core-inline.h +++ b/lib/std/core/core-inline.h @@ -21,9 +21,9 @@ static inline kk_std_core_types__order kk_int_as_order(int i,kk_context_t* ctx) static inline kk_std_core_types__maybe kk_integer_xparse( kk_string_t s, bool hex, kk_context_t* ctx ) { kk_integer_t i; - bool ok = (hex ? kk_integer_hex_parse(kk_string_cbuf_borrow(s,NULL),&i,ctx) : kk_integer_parse(kk_string_cbuf_borrow(s,NULL),&i,ctx) ); + bool ok = (hex ? kk_integer_hex_parse(kk_string_cbuf_borrow(s,NULL,ctx),&i,ctx) : kk_integer_parse(kk_string_cbuf_borrow(s,NULL,ctx),&i,ctx) ); kk_string_drop(s,ctx); - return (ok ? kk_std_core_types__new_Just(kk_integer_box(i),ctx) : kk_std_core_types__new_Nothing(ctx)); + return (ok ? kk_std_core_types__new_Just(kk_integer_box(i,ctx),ctx) : kk_std_core_types__new_Nothing(ctx)); } struct kk_std_core_Sslice; @@ -45,8 +45,9 @@ static inline kk_integer_t kk_string_cmp_int(kk_string_t s1, kk_string_t s2, kk_ kk_string_t kk_string_join(kk_vector_t v, kk_context_t* ctx); kk_string_t kk_string_join_with(kk_vector_t v, kk_string_t sep, kk_context_t* ctx); kk_string_t kk_string_replace_all(kk_string_t str, kk_string_t pattern, kk_string_t repl, kk_context_t* ctx); + static inline kk_integer_t kk_string_count_pattern(kk_string_t str, kk_string_t pattern, kk_context_t* ctx) { - kk_integer_t count = kk_integer_from_ssize_t( kk_string_count_pattern_borrow(str,pattern), ctx ); + kk_integer_t count = kk_integer_from_ssize_t( kk_string_count_pattern_borrow(str,pattern,ctx), ctx ); kk_string_drop(str,ctx); kk_string_drop(pattern,ctx); return count; @@ -65,7 +66,7 @@ kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_cont static inline kk_unit_t kk_vector_unsafe_assign( kk_vector_t v, kk_ssize_t i, kk_box_t x, kk_context_t* ctx ) { kk_ssize_t len; - kk_box_t* p = kk_vector_buf_borrow(v,&len); + kk_box_t* p = kk_vector_buf_borrow(v,&len,ctx); kk_assert(i < len); p[i] = x; kk_vector_drop(v,ctx); // TODO: use borrowing @@ -76,7 +77,7 @@ kk_vector_t kk_vector_init( kk_ssize_t n, kk_function_t init, kk_context_t* ctx) static inline kk_box_t kk_vector_at_int_borrow( kk_vector_t v, kk_integer_t n, kk_context_t* ctx) { // TODO: check bounds - kk_box_t b = kk_vector_at_borrow(v,kk_integer_clamp_ssize_t_borrow(n,ctx)); + kk_box_t b = kk_vector_at_borrow(v,kk_integer_clamp_ssize_t_borrow(n,ctx),ctx); return b; } @@ -87,7 +88,7 @@ static inline double kk_double_abs(double d) { static inline kk_std_core_types__tuple2_ kk_integer_div_mod_tuple(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_integer_t mod; kk_integer_t div = kk_integer_div_mod(x,y,&mod,ctx); - return kk_std_core_types__new_dash__lp__comma__rp_(kk_integer_box(div),kk_integer_box(mod),ctx); + return kk_std_core_types__new_dash__lp__comma__rp_(kk_integer_box(div,ctx),kk_integer_box(mod,ctx),ctx); } kk_box_t kk_main_console( kk_function_t action, kk_context_t* ctx ); diff --git a/lib/std/core/hnd-inline.c b/lib/std/core/hnd-inline.c index 6f90cf693..0081830e2 100644 --- a/lib/std/core/hnd-inline.c +++ b/lib/std/core/hnd-inline.c @@ -30,34 +30,34 @@ static kk_std_core_hnd__ev* kk_evv_vector_buf(kk_evv_vector_t vec, kk_ssize_t* l return &vec->vec[0]; } -static kk_std_core_hnd__ev* kk_evv_as_vec(kk_evv_t evv, kk_ssize_t* len, kk_std_core_hnd__ev* single) { - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); +static kk_std_core_hnd__ev* kk_evv_as_vec(kk_evv_t evv, kk_ssize_t* len, kk_std_core_hnd__ev* single, kk_context_t* ctx) { + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); *len = kk_block_scan_fsize(&vec->_block) - 1; return &vec->vec[0]; } else { // single evidence - *single = kk_evv_as_ev(evv); + *single = kk_evv_as_ev(evv,ctx); *len = 1; return single; } } kk_std_core_hnd__ev kk_ev_none(kk_context_t* ctx) { - static kk_std_core_hnd__ev ev_none_singleton; - if (ev_none_singleton==NULL) { + static kk_std_core_hnd__ev ev_none_singleton = kk_datatype_null_init; + if (kk_datatype_is_null(ev_none_singleton)) { ev_none_singleton = kk_std_core_hnd__new_Ev( kk_reuse_null, kk_std_core_hnd__new_Htag(kk_string_empty(),ctx), // tag "" kk_std_core_hnd__new_Marker(0,ctx), // marker 0 - kk_box_null, // no handler + kk_box_null(), // no handler -1, // bot kk_evv_empty(ctx), ctx ); } - return kk_std_core_hnd__ev_dup(ev_none_singleton); + return kk_std_core_hnd__ev_dup(ev_none_singleton,ctx); } @@ -65,10 +65,10 @@ kk_ssize_t kk_evv_index( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ) { // todo: drop htag? kk_ssize_t len; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* vec = kk_evv_as_vec(ctx->evv,&len,&single); + kk_std_core_hnd__ev* vec = kk_evv_as_vec(ctx->evv,&len,&single,ctx); for(kk_ssize_t i = 0; i < len; i++) { - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(vec[i]); - if (kk_string_cmp_borrow(htag.tagname,ev->htag.tagname) <= 0) return i; // break on insertion point + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(vec[i],ctx); + if (kk_string_cmp_borrow(htag.tagname,ev->htag.tagname,ctx) <= 0) return i; // break on insertion point } //string_t evvs = kk_evv_show(dup_datatype_as(kk_evv_t,ctx->evv),ctx); //fatal_error(EFAULT,"cannot find tag '%s' in: %s", string_cbuf_borrow(htag.htag), string_cbuf_borrow(evvs)); @@ -89,18 +89,18 @@ static inline int32_t kk_cfc_lub(int32_t cfc1, int32_t cfc2) { else return cfc2; } -static inline struct kk_std_core_hnd_Ev* kk_evv_as_Ev( kk_evv_t evv ) { - return kk_std_core_hnd__as_Ev(kk_evv_as_ev(evv)); +static inline struct kk_std_core_hnd_Ev* kk_evv_as_Ev( kk_evv_t evv, kk_context_t* ctx ) { + return kk_std_core_hnd__as_Ev(kk_evv_as_ev(evv,ctx),ctx); } static int32_t kk_evv_cfc_of_borrow(kk_evv_t evv, kk_context_t* ctx) { - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); return kk_integer_clamp32_borrow(vec->cfc,ctx); } else { - struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv); + struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv,ctx); return ev->cfc; } } @@ -110,24 +110,24 @@ int32_t kk_evv_cfc(kk_context_t* ctx) { } static void kk_evv_update_cfc_borrow(kk_evv_t evv, int32_t cfc, kk_context_t* ctx) { - kk_assert_internal(!kk_evv_is_empty(evv)); // should never happen (as named handlers are always in some context) - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); + kk_assert_internal(!kk_evv_is_empty(evv,ctx)); // should never happen (as named handlers are always in some context) + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); vec->cfc = kk_integer_from_int32(kk_cfc_lub(kk_integer_clamp32_borrow(vec->cfc,ctx),cfc), ctx); } else { - struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv); + struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv,ctx); ev->cfc = kk_cfc_lub(ev->cfc,cfc); } } kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx) { - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evd); + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evd,ctx); // update ev with parent evidence vector (either at init, or due to non-scoped resumptions) int32_t marker = ev->marker.m; if (marker==0) { kk_std_core_hnd__ev_drop(evd,ctx); return evvd; } // ev-none kk_evv_drop(ev->hevv,ctx); - ev->hevv = kk_evv_dup(evvd); + ev->hevv = kk_evv_dup(evvd,ctx); if (marker<0) { // negative marker is used for named evidence; this means this evidence should not be inserted into the evidence vector kk_evv_update_cfc_borrow(evvd,ev->cfc,ctx); // update cfc in-place for named evidence kk_std_core_hnd__ev_drop(evd,ctx); @@ -136,11 +136,11 @@ kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx // for regular handler evidence, insert ev kk_ssize_t n; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* const evv1 = kk_evv_as_vec(evvd, &n, &single); + kk_std_core_hnd__ev* const evv1 = kk_evv_as_vec(evvd, &n, &single, ctx); if (n == 0) { // use ev directly as the evidence vector kk_evv_drop(evvd, ctx); - return &evd->_block; + return kk_ev_as_evv(evd,ctx); } else { // create evidence vector @@ -150,23 +150,23 @@ kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx kk_std_core_hnd__ev* const evv2 = kk_evv_vector_buf(vec2, NULL); kk_ssize_t i; for (i = 0; i < n; i++) { - struct kk_std_core_hnd_Ev* ev1 = kk_std_core_hnd__as_Ev(evv1[i]); - if (kk_string_cmp_borrow(ev->htag.tagname, ev1->htag.tagname) <= 0) break; - evv2[i] = kk_std_core_hnd__ev_dup(&ev1->_base); + struct kk_std_core_hnd_Ev* ev1 = kk_std_core_hnd__as_Ev(evv1[i],ctx); + if (kk_string_cmp_borrow(ev->htag.tagname, ev1->htag.tagname,ctx) <= 0) break; + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } evv2[i] = evd; for (; i < n; i++) { - evv2[i+1] = kk_std_core_hnd__ev_dup(evv1[i]); + evv2[i+1] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } kk_evv_drop(evvd, ctx); // assigned to evidence already - return &vec2->_block; + return kk_datatype_from_base(vec2,ctx); } } kk_evv_t kk_evv_delete(kk_evv_t evvd, kk_ssize_t index, bool behind, kk_context_t* ctx) { kk_ssize_t n; kk_std_core_hnd__ev single; - const kk_std_core_hnd__ev* evv1 = kk_evv_as_vec(evvd, &n, &single); + const kk_std_core_hnd__ev* evv1 = kk_evv_as_vec(evvd, &n, &single, ctx); if (n <= 1) { kk_evv_drop(evvd,ctx); return kk_evv_total(ctx); @@ -179,45 +179,45 @@ kk_evv_t kk_evv_delete(kk_evv_t evvd, kk_ssize_t index, bool behind, kk_context_ kk_std_core_hnd__ev* const evv2 = kk_evv_vector_buf(vec2,NULL); kk_ssize_t i; for(i = 0; i < index; i++) { - evv2[i] = kk_std_core_hnd__ev_dup(evv1[i]); + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } for(; i < n-1; i++) { - evv2[i] = kk_std_core_hnd__ev_dup(evv1[i+1]); + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i+1],ctx); } - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evv1[index]); + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evv1[index],ctx); if (ev->cfc >= cfc1) { - int32_t cfc = kk_std_core_hnd__as_Ev(evv2[0])->cfc; + int32_t cfc = kk_std_core_hnd__as_Ev(evv2[0],ctx)->cfc; for(i = 1; i < n-1; i++) { - cfc = kk_cfc_lub(cfc,kk_std_core_hnd__as_Ev(evv2[i])->cfc); + cfc = kk_cfc_lub(cfc,kk_std_core_hnd__as_Ev(evv2[i],ctx)->cfc); } vec2->cfc = kk_integer_from_int32(cfc,ctx); } kk_evv_drop(evvd,ctx); - return &vec2->_block; + return kk_datatype_from_base(vec2,ctx); } kk_evv_t kk_evv_create(kk_evv_t evv1, kk_vector_t indices, kk_context_t* ctx) { kk_ssize_t len; - kk_box_t* elems = kk_vector_buf_borrow(indices,&len); // borrows + kk_box_t* elems = kk_vector_buf_borrow(indices,&len,ctx); // borrows kk_evv_vector_t evv2 = kk_evv_vector_alloc(len,kk_evv_cfc_of_borrow(evv1,ctx),ctx); kk_std_core_hnd__ev* buf2 = kk_evv_vector_buf(evv2,NULL); - kk_assert_internal(kk_evv_is_vector(evv1)); + kk_assert_internal(kk_evv_is_vector(evv1,ctx)); kk_ssize_t len1; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* buf1 = kk_evv_as_vec(evv1,&len1,&single); + kk_std_core_hnd__ev* buf1 = kk_evv_as_vec(evv1,&len1,&single,ctx); for(kk_ssize_t i = 0; i < len; i++) { kk_ssize_t idx = kk_ssize_unbox(elems[i],ctx); kk_assert_internal(idx < len1); - buf2[i] = kk_std_core_hnd__ev_dup( buf1[idx] ); + buf2[i] = kk_std_core_hnd__ev_dup( buf1[idx], ctx ); } kk_vector_drop(indices,ctx); kk_evv_drop(evv1,ctx); - return &evv2->_block; + return kk_datatype_from_base(evv2,ctx); } kk_evv_t kk_evv_swap_create( kk_vector_t indices, kk_context_t* ctx ) { kk_ssize_t len; - kk_box_t* vec = kk_vector_buf_borrow(indices,&len); + kk_box_t* vec = kk_vector_buf_borrow(indices,&len,ctx); if (len==0) { kk_vector_drop(indices,ctx); return kk_evv_swap_create0(ctx); @@ -227,7 +227,7 @@ kk_evv_t kk_evv_swap_create( kk_vector_t indices, kk_context_t* ctx ) { kk_vector_drop(indices,ctx); return kk_evv_swap_create1(i,ctx); } - return kk_evv_swap( kk_evv_create(kk_evv_dup(ctx->evv),indices,ctx), ctx ); + return kk_evv_swap( kk_evv_create(kk_evv_dup(ctx->evv,ctx),indices,ctx), ctx ); } @@ -248,19 +248,19 @@ struct kcompose_fun_s { // kleisli composition of continuations static kk_box_t kcompose( kk_function_t fself, kk_box_t x, kk_context_t* ctx) { - struct kcompose_fun_s* self = kk_function_as(struct kcompose_fun_s*,fself); + struct kcompose_fun_s* self = kk_function_as(struct kcompose_fun_s*,fself,ctx); kk_intx_t count = kk_intf_unbox(self->count); kk_function_t* conts = &self->conts[0]; // call each continuation in order for(kk_intx_t i = 0; i < count; i++) { // todo: take uniqueness of fself into account to avoid dup_function - kk_function_t f = kk_function_dup(conts[i]); - x = kk_function_call(kk_box_t, (kk_function_t, kk_box_t, kk_context_t*), f, (f, x, ctx)); + kk_function_t f = kk_function_dup(conts[i],ctx); + x = kk_function_call(kk_box_t, (kk_function_t, kk_box_t, kk_context_t*), f, (f, x, ctx), ctx); if (kk_yielding(ctx)) { // if yielding, `yield_next` all continuations that still need to be done while(++i < count) { // todo: if fself is unique, we could copy without dup? - kk_yield_extend(kk_function_dup(conts[i]),ctx); + kk_yield_extend(kk_function_dup(conts[i],ctx),ctx); } kk_function_drop(fself,ctx); kk_box_drop(x,ctx); // still drop even though we yield as it may release a boxed value type? @@ -271,16 +271,16 @@ static kk_box_t kcompose( kk_function_t fself, kk_box_t x, kk_context_t* ctx) { return x; } -static kk_function_t new_kcompose( kk_function_t* conts, kk_ssize_t count, kk_context_t* ctx ) { +static kk_function_t new_kcompose( kk_function_t* conts, kk_intf_t count, kk_context_t* ctx ) { if (count==0) return kk_function_id(ctx); if (count==1) return conts[0]; struct kcompose_fun_s* f = kk_block_as(struct kcompose_fun_s*, kk_block_alloc(kk_ssizeof(struct kcompose_fun_s) - kk_ssizeof(kk_function_t) + (count*kk_ssizeof(kk_function_t)), 2 + count /* scan size */, KK_TAG_FUNCTION, ctx)); - f->_base.fun = kk_cfun_ptr_box(&kcompose,ctx); + f->_base.fun = kk_kkfun_ptr_box(&kcompose,ctx); f->count = kk_intf_box(count); kk_memcpy(f->conts, conts, count * kk_ssizeof(kk_function_t)); - return (&f->_base); + return kk_datatype_from_base(&f->_base,ctx); } /*----------------------------------------------------------------------- @@ -314,19 +314,19 @@ struct cont_apply_fun_s { }; static kk_box_t cont_apply( kk_function_t fself, kk_box_t x, kk_context_t* ctx ) { - struct cont_apply_fun_s* self = kk_function_as(struct cont_apply_fun_s*, fself); + struct cont_apply_fun_s* self = kk_function_as(struct cont_apply_fun_s*, fself, ctx); kk_function_t f = self->f; kk_function_t cont = self->cont; - kk_drop_match(self,{kk_function_dup(f);kk_function_dup(cont);},{},ctx); - return kk_function_call( kk_box_t, (kk_function_t, kk_function_t, kk_box_t, kk_context_t* ctx), f, (f, cont, x, ctx)); + kk_drop_match(self,{kk_function_dup(f,ctx);kk_function_dup(cont,ctx);},{},ctx); + return kk_function_call( kk_box_t, (kk_function_t, kk_function_t, kk_box_t, kk_context_t* ctx), f, (f, cont, x, ctx), ctx); } static kk_function_t kk_new_cont_apply( kk_function_t f, kk_function_t cont, kk_context_t* ctx ) { struct cont_apply_fun_s* self = kk_function_alloc_as(struct cont_apply_fun_s, 3, ctx); - self->_base.fun = kk_cfun_ptr_box(&cont_apply,ctx); + self->_base.fun = kk_kkfun_ptr_box(&cont_apply,ctx); self->f = f; self->cont = cont; - return (&self->_base); + return kk_datatype_from_base(&self->_base,ctx); } // Unlike `yield_extend`, `yield_cont` gets access to the current continuation. This is used in `yield_prompt`. @@ -351,7 +351,7 @@ kk_function_t kk_yield_to( struct kk_std_core_hnd_Marker m, kk_function_t clause yield->marker = m.m; yield->clause = clause; yield->conts_count = 0; - return kk_basetype_unbox_as(kk_function_t,kk_box_any(ctx)); + return kk_datatype_unbox(kk_box_any(ctx)); } kk_box_t kk_yield_final( struct kk_std_core_hnd_Marker m, kk_function_t clause, kk_context_t* ctx ) { @@ -371,7 +371,7 @@ static kk_box_t _fatal_resume_final(kk_function_t self, kk_context_t* ctx) { } static kk_function_t fun_fatal_resume_final(kk_context_t* ctx) { kk_define_static_function(f,_fatal_resume_final,ctx); - return kk_function_dup(f); + return kk_function_dup(f,ctx); } @@ -395,7 +395,7 @@ struct kk_std_core_hnd_yld_s kk_yield_prompt( struct kk_std_core_hnd_Marker m, k } kk_unit_t kk_evv_guard(kk_evv_t evv, kk_context_t* ctx) { - bool eq = (ctx->evv == evv); + bool eq = kk_datatype_eq(ctx->evv,evv); kk_evv_drop(evv,ctx); if (!eq) { // todo: improve error message with diagnostics @@ -408,7 +408,7 @@ typedef struct yield_info_s { struct kk_std_core_hnd__yield_info_s _base; kk_function_t clause; kk_function_t conts[KK_YIELD_CONT_MAX]; - kk_ssize_t conts_count; + kk_intf_t conts_count; int32_t marker; int8_t yielding; }* yield_info_t; @@ -429,18 +429,18 @@ kk_std_core_hnd__yield_info kk_yield_capture(kk_context_t* ctx) { yld->yielding = ctx->yielding; ctx->yielding = 0; ctx->yield.conts_count = 0; - return kk_datatype_from_base(&yld->_base); + return kk_datatype_from_base(&yld->_base,ctx); } kk_box_t kk_yield_reyield( kk_std_core_hnd__yield_info yldinfo, kk_context_t* ctx) { kk_assert_internal(!kk_yielding(ctx)); - yield_info_t yld = kk_datatype_as_assert(yield_info_t, yldinfo, (kk_tag_t)1); - ctx->yield.clause = kk_function_dup(yld->clause); + yield_info_t yld = kk_datatype_as_assert(yield_info_t, yldinfo, (kk_tag_t)1, ctx); + ctx->yield.clause = kk_function_dup(yld->clause,ctx); ctx->yield.marker = yld->marker; ctx->yield.conts_count = yld->conts_count; ctx->yielding = yld->yielding; for(kk_ssize_t i = 0; i < yld->conts_count; i++) { - ctx->yield.conts[i] = kk_function_dup(yld->conts[i]); + ctx->yield.conts[i] = kk_function_dup(yld->conts[i],ctx); } kk_constructor_drop(yld,ctx); return kk_box_any(ctx); diff --git a/lib/std/core/hnd-inline.h b/lib/std/core/hnd-inline.h index e8168e3bd..b3883adb4 100644 --- a/lib/std/core/hnd-inline.h +++ b/lib/std/core/hnd-inline.h @@ -1,3 +1,9 @@ + + + + + + /*--------------------------------------------------------------------------- Copyright 2020-2021, Microsoft Research, Daan Leijen. @@ -5,64 +11,72 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -struct kk_std_core_hnd__ev_s; -static inline struct kk_std_core_hnd__ev_s* kk_std_core_hnd__ev_dup(struct kk_std_core_hnd__ev_s* _x); +typedef kk_datatype_ptr_t kk_std_core_hnd__ev_t; +static inline kk_std_core_hnd__ev_t kk_std_core_hnd__ev_dup(kk_std_core_hnd__ev_t _x, kk_context_t* ctx); typedef struct kk_evv_vector_s { - struct kk_block_s _block; - kk_integer_t cfc; // control flow context (0-3) as a small int - struct kk_std_core_hnd__ev_s* vec[1]; + struct kk_block_s _block; + kk_integer_t cfc; // control flow context (0-3) as a small int + kk_std_core_hnd__ev_t vec[1]; } *kk_evv_vector_t; -typedef kk_ptr_t kk_evv_t; // either a kk_evv_vector_t, or a single evidence +typedef kk_datatype_ptr_t kk_evv_t; // either a kk_evv_vector_t, or a single evidence -static inline kk_evv_t kk_evv_dup(kk_evv_t evv) { - return kk_block_dup(evv); +static inline kk_evv_t kk_evv_dup(kk_evv_t evv, kk_context_t* ctx) { + return kk_datatype_ptr_dup(evv,ctx); } static inline void kk_evv_drop(kk_evv_t evv, kk_context_t* ctx) { - kk_block_drop(evv,ctx); + kk_datatype_ptr_drop(evv,ctx); } static inline kk_evv_t kk_evv_empty(kk_context_t* ctx) { - kk_unused(ctx); - return kk_evv_dup(kk_evv_empty_singleton); + return kk_evv_empty_singleton(ctx); } -static inline bool kk_evv_is_empty(kk_evv_t evv) { - return (evv == kk_evv_empty_singleton); +static inline bool kk_evv_is_empty(kk_evv_t evv, kk_context_t* ctx) { // todo: optimize + kk_evv_t empty = kk_evv_empty(ctx); + bool eq = kk_datatype_eq(evv,empty); + kk_datatype_ptr_drop(empty,ctx); + return eq; } -static inline bool kk_evv_is_vector(kk_evv_t evv) { - return kk_block_has_tag(evv,KK_TAG_EVV_VECTOR); +static inline bool kk_evv_is_vector(kk_evv_t evv, kk_context_t* ctx) { + return kk_datatype_ptr_has_tag(evv,KK_TAG_EVV_VECTOR,ctx); } -static inline struct kk_std_core_hnd__ev_s* kk_evv_as_ev( kk_evv_t evv ) { - kk_assert_internal(!kk_evv_is_vector(evv)); - return (struct kk_std_core_hnd__ev_s*)evv; +static inline kk_std_core_hnd__ev_t kk_evv_as_ev( kk_evv_t evv, kk_context_t* ctx ) { + kk_unused_internal(ctx); + kk_assert_internal(!kk_evv_is_vector(evv,ctx)); + return evv; +} + +static inline kk_evv_t kk_ev_as_evv( kk_std_core_hnd__ev_t ev, kk_context_t* ctx ) { + kk_unused(ctx); + return ev; } -static inline kk_evv_vector_t kk_evv_as_vector( kk_evv_t evv ) { - kk_assert_internal(kk_evv_is_vector(evv)); - return (kk_evv_vector_t)evv; +static inline kk_evv_vector_t kk_evv_as_vector( kk_evv_t evv, kk_context_t* ctx ) { + kk_assert_internal(kk_evv_is_vector(evv,ctx)); + return kk_datatype_as_assert(kk_evv_vector_t,evv,KK_TAG_EVV_VECTOR,ctx); } -static inline struct kk_std_core_hnd__ev_s* kk_evv_at( kk_ssize_t i, kk_context_t* ctx ) { +static inline kk_std_core_hnd__ev_t kk_evv_at( kk_ssize_t i, kk_context_t* ctx ) { kk_evv_t evv = ctx->evv; - if (!kk_evv_is_vector(evv)) { // evv is a single evidence + if (!kk_evv_is_vector(evv,ctx)) { // evv is a single evidence kk_assert_internal(i==0); - return kk_evv_as_ev(kk_evv_dup(evv)); + return kk_evv_as_ev(kk_evv_dup(evv,ctx),ctx); } else { // evv as a vector - kk_assert_internal(i >= 0 && i < (kk_block_scan_fsize(evv) - 1)); - kk_evv_vector_t vec = kk_evv_as_vector(evv); - return kk_std_core_hnd__ev_dup(vec->vec[i]); + kk_assert_internal(i >= 0 && i < (kk_block_scan_fsize(kk_datatype_as_ptr(evv,ctx)) - 1)); + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); + return kk_std_core_hnd__ev_dup(vec->vec[i],ctx); } } static inline kk_evv_t kk_evv_get(kk_context_t* ctx) { - return kk_evv_dup(ctx->evv); + return kk_evv_dup(ctx->evv,ctx); } static inline kk_unit_t kk_evv_set(kk_evv_t evv, kk_context_t* ctx) { @@ -72,13 +86,13 @@ static inline kk_unit_t kk_evv_set(kk_evv_t evv, kk_context_t* ctx) { } static inline kk_evv_t kk_evv_swap(kk_evv_t evv, kk_context_t* ctx) { - kk_ptr_t evv0 = ctx->evv; + kk_evv_t evv0 = ctx->evv; ctx->evv = evv; return evv0; } static inline bool kk_evv_eq(kk_evv_t evv1, kk_evv_t evv2, kk_context_t* ctx) { // TODO:make borrowing - bool eq = (evv1 == evv2); + bool eq = kk_datatype_eq(evv1,evv2); kk_evv_drop(evv1,ctx); kk_evv_drop(evv2,ctx); return eq; @@ -94,13 +108,13 @@ static inline kk_evv_t kk_evv_swap_create0(kk_context_t* ctx) { static inline kk_evv_t kk_evv_swap_create1(kk_ssize_t i, kk_context_t* ctx) { kk_evv_t evv0 = ctx->evv; - if (kk_evv_is_vector(evv0)) { - ctx->evv = (kk_block_t*)kk_evv_at(i, ctx); // cast as ev struct is not defined yet + if (kk_evv_is_vector(evv0,ctx)) { + ctx->evv = kk_evv_at(i, ctx); // cast as ev struct is not defined yet return evv0; } else { kk_assert_internal(i==0); - return kk_evv_dup(evv0); // already a single evidence + return kk_evv_dup(evv0,ctx); // already a single evidence } } @@ -109,12 +123,12 @@ struct kk_std_core_hnd_Marker; struct kk_std_core_hnd_yld_s; -struct kk_std_core_hnd__ev_s* kk_ev_none(kk_context_t* cxt); -struct kk_std_core_hnd__ev_s* kk_evv_lookup( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); +kk_std_core_hnd__ev_t kk_ev_none(kk_context_t* cxt); +kk_std_core_hnd__ev_t kk_evv_lookup( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); int32_t kk_evv_cfc(kk_context_t* ctx); kk_ssize_t kk_evv_index( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); kk_evv_t kk_evv_create(kk_evv_t evv, kk_vector_t indices, kk_context_t* ctx); -kk_evv_t kk_evv_insert(kk_evv_t evv, struct kk_std_core_hnd__ev_s* ev, kk_context_t* ctx); +kk_evv_t kk_evv_insert(kk_evv_t evv, kk_std_core_hnd__ev_t ev, kk_context_t* ctx); kk_evv_t kk_evv_delete(kk_evv_t evv, kk_ssize_t index, bool behind, kk_context_t* ctx); kk_string_t kk_evv_show(kk_evv_t evv, kk_context_t* ctx); kk_unit_t kk_evv_guard(kk_evv_t evv, kk_context_t* ctx); @@ -131,6 +145,6 @@ kk_box_t kk_yield_reyield(kk_datatype_t yld, kk_context_t* ctx); static inline kk_evv_t kk_evv_swap_delete(kk_ssize_t i, bool behind, kk_context_t* ctx) { kk_evv_t evv0 = ctx->evv; - ctx->evv = kk_evv_delete(kk_evv_dup(evv0), i, behind, ctx); + ctx->evv = kk_evv_delete(kk_evv_dup(evv0,ctx), i, behind, ctx); return evv0; } diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 8183564e8..2edc23ab1 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -356,13 +356,7 @@ genTopDefDecl genSig inlineC def@(Def name tp defBody vis sort inl rng comm) genFunDef tnames app -- special case string literals Lit (LitString s) - -> do let (cstr,clen) = cstring s - decl = if (isPublic vis) then empty else text "static" - if (clen > 0) - then emitToC (text "kk_define_string_literal" <.> tupled [decl,ppName name,pretty clen,cstr] {- <.> semi -}) - else emitToC (text "kk_define_string_literal_empty" <.> tupled [decl, ppName name]) - when (isPublic vis) $ - emitToH (linebreak <.> text "extern" <+> ppType typeString <+> ppName name <.> semi) + -> do genTopLevelStringLiteral name vis s -- special case for doubles Lit lit@(LitFloat f) -> do let flt = ppLit lit @@ -411,6 +405,18 @@ unitSemi :: Type -> Doc unitSemi tp = if (isTypeUnit tp) then text " = kk_Unit;" else semi +genTopLevelStringLiteral :: Name -> Visibility -> String -> Asm () +genTopLevelStringLiteral name vis s + = do let (cstr,clen) = cstring s + decl = if (isPublic vis) then empty else text "static" + if (clen > 0) + then do emitToC (text "kk_declare_string_literal" <.> tupled [decl,ppName name,pretty clen,cstr] {- <.> semi -}) + emitToInit (text "kk_init_string_literal" <.> arguments [ppName name]) + -- todo: emit drop in Done? + else emitToC (text "kk_define_string_literal_empty" <.> tupled [decl, ppName name]) + when (isPublic vis) $ + emitToH (linebreak <.> text "extern" <+> ppType typeString <+> ppName name <.> semi) + --------------------------------------------------------------------------------- -- Generate value constructors for each defined type --------------------------------------------------------------------------------- @@ -457,7 +463,7 @@ genTypeDefPre (Data info isExtend) (if dataReprMayHaveSingletons dataRepr then (text "typedef kk_datatype_t" <+> ppName (typeClassName name) <.> semi) else ( -- text "typedef struct" <+> ppName (typeClassName name) <.> text "_s*" <+> ppName (typeClassName name) <.> semi)) - text "typedef kk_basetype_t" <+> ppName (typeClassName name) <.> semi)) + text "typedef kk_datatype_ptr_t" <+> ppName (typeClassName name) <.> semi)) genTypeDefPost:: TypeDef -> Asm () genTypeDefPost (Synonym synInfo) @@ -564,11 +570,11 @@ genConstructorTest info dataRepr (con,conRepr,conFields,scanCount) genConstructorTestX :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> Asm () genConstructorTestX info dataRepr con conRepr - = do emitToH $ text "static inline bool" <+> (conTestName con) <.> tupled [ppName (typeClassName (dataInfoName info)) <+> text "x"] + = do emitToH $ text "static inline bool" <+> (conTestName con) <.> parameters [ppName (typeClassName (dataInfoName info)) <+> text "x"] <+> block( text "return (" <.> ( let nameDoc = ppName (conInfoName con) -- tagDoc = text "datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" - dataTypeTagDoc = text "kk_datatype_tag" <.> tupled [text "x"] + dataTypeTagDoc = text "kk_datatype_tag" <.> arguments [text "x"] valueTagEq = text "kk_value_tag_eq(x._tag," <+> ppConTag con conRepr dataRepr <.> text ")" in case conRepr of ConEnum{} -> text "x ==" <+> ppConTag con conRepr dataRepr @@ -579,19 +585,23 @@ genConstructorTestX info dataRepr con conRepr ConSingle{} -> text "true" ConStruct{} -> valueTagEq ConAsJust{conAsNothing=nothing} - -> text "!" <.> conTestNameX nothing <.> tupled [text "x"] + -> text "!" <.> conTestNameX nothing <.> arguments [text "x"] ConAsCons{conAsNil=nil} -> -- todo: is_ptr may be faster on arm64? -- text "kk_datatype_is_ptr(x)" - text "!" <.> conTestNameX nil <.> tupled [text "x"] + text "!" <.> conTestNameX nil <.> arguments [text "x"] ConNormal{} -- | dataRepr == DataSingleNormal -> text "datatype_is_ptr(x)" -- | otherwise -> text "datatype_is_ptr(x) && datatype_tag_fast(x) ==" <+> ppConTag con conRepr dataRepr -- -> text "datatype_tag(x) ==" <+> ppConTag con conRepr dataRepr -> text (if (dataReprMayHaveSingletons dataRepr) - then "kk_datatype_has_ptr_tag" else "kk_basetype_has_tag") - <.> tupled [text "x", ppConTag con conRepr dataRepr] - ConOpen{} -> text "kk_string_ptr_eq_borrow" <.> tupled [text "x->_tag",ppConTag con conRepr dataRepr] + then "kk_datatype_has_ptr_tag" else "kk_datatype_ptr_has_tag") + <.> arguments [text "x", ppConTag con conRepr dataRepr] + ConOpen{} -> let opentag = parens ( + text "kk_datatype_as" <.> arguments [ + text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s*", text "x"] + ) <.> text "->_tag" + in text "kk_string_ptr_eq_borrow" <.> tupled [opentag,ppConTag con conRepr dataRepr] ) <.> text ");") conTestName con @@ -676,7 +686,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount then ppConTag con conRepr dataRepr else text "KK_TAG_OPEN"] <.> semi] - ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> parens(ppConTag con conRepr dataRepr) <.> semi ]) + ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> arguments [ppConTag con conRepr dataRepr] <.> semi ]) ++ map (assignField (\fld -> tmp <.> text "->" <.> fld)) conFields ++ {- [let base = text "&" <.> tmp <.> text "->_base" in if (dataReprMayHaveSingletons dataRepr) @@ -698,11 +708,7 @@ genConstructorBaseCast info dataRepr con conRepr <.> parameters [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] <+> block ( let base = text "&_x->_base" - in text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_from_base" - else text "kk_basetype_from_base") - <+> arguments [base] <.> semi + in text "return" <+> text "kk_datatype_from_base" <+> arguments [base] <.> semi ) @@ -717,7 +723,7 @@ genConstructorAccess info dataRepr con conRepr <+> block( vcat $ [-- text "assert(" <.> conTestName con <.> tupled [text "x"] <.> text ");", text "return" <+> - text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_as_assert" else "kk_basetype_as_assert") <.> + text "kk_datatype_as_assert" <.> arguments [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr <+> text "/* _tag */")] <.> semi] ) @@ -732,8 +738,8 @@ genBoxUnbox name info dataRepr genBoxCall prim asBorrowed tp arg = case cType tp of - CFun _ _ -> primName_t prim "function_t" <.> parens arg - CPrim val | val == "kk_unit_t" || val == "kk_integer_t" || val == "bool" || val == "kk_string_t" + CFun _ _ -> primName_t prim "function_t" <.> tupled [arg,ctx] + CPrim val | val == "kk_unit_t" || val == "bool" || val == "kk_string_t" -- || val == "kk_integer_t" -> primName_t prim val <.> parens arg -- no context --CPrim val | val == "int32_t" || val == "double" || val == "unit_t" -- -> text val <.> arguments [arg] @@ -760,7 +766,7 @@ genBox name info dataRepr DataStructAsMaybe -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) - in text "if" <+> parens (conTestName conNothing <.> tupled [text "_x"]) <+> (text "return kk_box_Nothing();") + in text "if" <+> parens (conTestName conNothing <.> arguments [text "_x"]) <+> (text "return kk_box_Nothing();") <-> text " else" <+> ( let boxField = genBoxCall "box" False conJustFieldTp @@ -771,14 +777,14 @@ genBox name info dataRepr DataDefValue raw scancount -> let -- extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors docScanCount = if (hasTagField dataRepr) - then ppName name <.> text "_scan_count" <.> parens (text "_x") + then ppName name <.> text "_scan_count" <.> arguments [text "_x"] else pretty scancount <+> text "/* scan count */" in vcat [ text "kk_box_t _box;" , text "kk_valuetype_box" <.> arguments [ppName name, text "_box", text "_x", docScanCount ] <.> semi , text "return _box;" ] - _ -> text "return" <+> text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_box" else "kk_basetype_box") <.> tupled [text "_x"] <.> semi + _ -> text "return" <+> text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_box" else "kk_datatype_ptr_box") <.> tupled [text "_x"] <.> semi ) genUnbox name info dataRepr @@ -816,7 +822,7 @@ genUnbox name info dataRepr _ -> text "return" <+> ((if dataReprMayHaveSingletons dataRepr then text "kk_datatype_unbox" - else text "kk_basetype_unbox") + else text "kk_datatype_ptr_unbox") <.> tupled [text "_x"]) ) <.> semi) @@ -841,71 +847,51 @@ genIsUnique :: Name -> DataInfo -> DataRepr -> Asm () genIsUnique name info dataRepr = emitToH $ text "static inline bool" <+> ppName name <.> text "_is_unique" <.> parameters [ppName name <+> text "_x"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_is_unique" - else text "kk_basetype_is_unique" - ) <.> arguments [text "_x"] <.> semi) + text "return" <+> text "kk_datatype_ptr_is_unique" <.> arguments [text "_x"] <.> semi + ) genFree :: Name -> DataInfo -> DataRepr -> Asm () genFree name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_free" <.> parameters [ppName name <+> text "_x"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_free" - else text "kk_basetype_free" - ) <.> arguments [text "_x"] <.> semi) + text "kk_datatype_ptr_free" <.> arguments [text "_x"] <.> semi + ) genDecRef :: Name -> DataInfo -> DataRepr -> Asm () genDecRef name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_decref" <.> parameters [ppName name <+> text "_x"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_decref" - else text "kk_basetype_decref" - ) <.> arguments [text "_x"] <.> semi) + text "kk_datatype_ptr_decref" <.> arguments [text "_x"] <.> semi + ) genDropReuseFun :: Name -> DataInfo -> DataRepr -> Asm () genDropReuseFun name info dataRepr = emitToH $ text "static inline kk_reuse_t" <+> ppName name <.> text "_dropn_reuse" <.> parameters [ppName name <+> text "_x", text "kk_ssize_t _scan_fsize"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_dropn_reuse" - else text "kk_basetype_dropn_reuse" - ) <.> arguments [text "_x", text "_scan_fsize"] <.> semi) + text "return" <+> text "kk_datatype_ptr_dropn_reuse" <.> arguments [text "_x", text "_scan_fsize"] <.> semi + ) genDropNFun :: Name -> DataInfo -> DataRepr -> Asm () genDropNFun name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_dropn" <.> parameters [ppName name <+> text "_x", text "kk_ssize_t _scan_fsize"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_dropn" - else text "kk_basetype_dropn" - ) <.> arguments [text "_x", text "_scan_fsize"] <.> semi) + text "kk_datatype_ptr_dropn" <.> arguments [text "_x", text "_scan_fsize"] <.> semi) genReuse :: Name -> DataInfo -> DataRepr -> Asm () genReuse name info dataRepr = emitToH $ text "static inline kk_reuse_t" <+> ppName name <.> text "_reuse" <.> parameters [ppName name <+> text "_x"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_reuse" - else text "kk_basetype_reuse" - ) <.> arguments [text "_x"] <.> semi) + text "return" <+> text "kk_datatype_ptr_reuse" <.> arguments [text "_x"] <.> semi) genHole :: Name -> DataInfo -> DataRepr -> Asm () genHole name info dataRepr = emitToH $ - text "static inline" <+> ppName name <+> ppName name <.> text "_hole()" <+> block ( + text "static inline" <+> ppName name <+> ppName name <.> text "_hole(void)" <+> block ( text "return" <+> -- holes must be trace-able and look like values (least-significant-bit==1) - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_from_tag((kk_tag_t)0)" - else text "kk_basetype_invalid_from_tag((kk_tag_t)0)" - ) <.> semi) + text "kk_datatype_null()" <.> semi) genScanFields :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () @@ -913,14 +899,14 @@ genScanFields name info dataRepr conInfos | not (hasTagField dataRepr) = return () genScanFields name info dataRepr conInfos = emitToH $ - text "static inline kk_ssize_t" <+> ppName name <.> text "_scan_count" <.> tupled [ppName name <+> text "_x"] + text "static inline kk_ssize_t" <+> ppName name <.> text "_scan_count" <.> parameters [ppName name <+> text "_x"] <+> block (vcat (map (genScanFieldTests (length conInfos)) (zip conInfos [1..]))) genScanFieldTests :: Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc genScanFieldTests lastIdx ((con,conRepr,conFields,scanCount),idx) = if (lastIdx == idx) then (text "else" <+> stat) - else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> tupled [text "_x"])) + else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> arguments [text "_x"])) <+> stat where stat = text ("return " ++ show (1 {-tag-} + scanCount) ++ ";") @@ -942,10 +928,10 @@ genDupDropX isDup name info dataRepr conInfos <+> (if dataReprMayHaveSingletons dataRepr then text "kk_datatype_dup" <.> arguments [text "_x"] else -- text "kk_basetype_dup_as" <.> arguments [ppName name, text "_x"]) - text "kk_basetype_dup" <.> arguments [text "_x"]) + text "kk_datatype_ptr_dup" <.> arguments [text "_x"]) <.> semi] else [text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_drop" - else "kk_basetype_drop") + else "kk_datatype_ptr_drop") <.> arguments [text "_x"] <.> semi] genDupDropIso :: Bool -> (ConInfo,ConRepr,[(Name,Type)],Int) -> Doc @@ -963,7 +949,7 @@ genDupDropTests isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) else if (lastIdx == 1) then vcat stats else text "else" <+> block (vcat stats)) - else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> tupled [text "_x"])) + else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> arguments [text "_x"])) <+> (if null stats then text "{ }" else block (vcat stats)) genDupDropFields :: Bool -> DataRepr -> ConInfo -> [(Name,Type)] -> [Doc] @@ -1115,12 +1101,12 @@ genLambda params eff body then [text "kk_define_static_function" <.> arguments [text "_fself", ppName funName] -- <.> semi --text "static" <+> structDoc <+> text "_self =" -- <+> braces (braces (text "static_header(1, TAG_FUNCTION), box_cptr(&" <.> ppName funName <.> text ")")) <.> semi - ,text "return kk_function_dup(_fself);"] + ,text "return kk_function_dup(_fself,kk_context());"] else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty (scanCount + 1) -- +1 for the _base.fun ] <.> semi ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] - ++ [text "return kk_basetype_from_base(&_self->_base, kk_context());"]) + ++ [text "return kk_datatype_from_base(&_self->_base, kk_context());"]) ) @@ -1496,7 +1482,7 @@ genPatternTest doTest gfree (exprDoc,pattern) -> do let next = genNextPatterns (\self fld -> text "kk_datatype_unJust" <.> arguments [self]) exprDoc (typeOf tname) patterns - return [(xtest [conTestName info <.> parens exprDoc],[],next)] + return [(xtest [conTestName info <.> arguments [exprDoc]],[],next)] _ -> let dataRepr = conDataRepr repr in if (dataReprIsValue dataRepr || isConSingleton repr) then valTest tname info dataRepr @@ -1512,14 +1498,14 @@ genPatternTest doTest gfree (exprDoc,pattern) then "._cons." ++ show (ppDefName (getName conName)) ++ "." else "." next = genNextPatterns (\self fld -> self <.> text selectOp <.> fld) exprDoc (typeOf tname) patterns - return [(xtest [conTestName conInfo <.> tupled [exprDoc]],[],next)] + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[],next)] conTest conInfo = do local <- newVarName "con" let next = genNextPatterns (\self fld -> self <.> text "->" <.> fld) (ppDefName local) (typeOf tname) patterns typeDoc = text "struct" <+> ppName (conInfoName conInfo) <.> text "*" assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> arguments [exprDoc] <.> semi - return [(xtest [conTestName conInfo <.> parens exprDoc],[assign],next)] + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[assign],next)] patternVarFree pat = case pat of @@ -1594,8 +1580,8 @@ genExprPrim expr if (s=="") then return ([],text "kk_string_empty()") else do let (cstr,clen) = cstring s - return ([text "kk_define_string_literal" <.> tupled [empty,ppName name,pretty clen,cstr]] - ,text "kk_string_dup" <.> parens (ppName name)); + return ([text "kk_define_string_literal" <.> arguments [empty,ppName name,pretty clen,cstr]] + ,text "kk_string_dup" <.> arguments [ppName name]); Var vname (InfoExternal formats) -> case splitFunScheme (typeOf vname) of @@ -1865,13 +1851,13 @@ genAssignFields tmp conName reuseName fieldNames fieldValues genFieldAddress :: TName -> Name -> Name -> Doc genFieldAddress conVar conName fieldName - = parens (text "&" <.> conAsNameX (conName) <.> parens (ppName (getName conVar)) <.> text "->" <.> ppName (unqualify fieldName)) + = parens (text "&" <.> conAsNameX (conName) <.> arguments [ppName (getName conVar)] <.> text "->" <.> ppName (unqualify fieldName)) genCTailSetContextPath :: TName -> Name -> Name -> Doc genCTailSetContextPath conVar conName fieldName = text "kk_ctail_set_context_path" <.> - tupled [conAsNameX conName, ppName (getName conVar), - text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] + arguments [conAsNameX conName, ppName (getName conVar), + text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] genAppSpecial :: Expr -> [Expr] -> Asm (Maybe Doc) genAppSpecial f args From d3ed13887d227a5d705060d9985986e8412ef1d5 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 7 Dec 2022 11:28:08 -0800 Subject: [PATCH 093/233] wip: small fixes --- kklib/include/kklib.h | 14 ++++++++++++-- kklib/include/kklib/platform.h | 4 ---- kklib/src/init.c | 2 +- lib/std/num/float64-inline.c | 2 +- 4 files changed, 14 insertions(+), 8 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 66b3f646b..7d40e3bb5 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 96 // modify on changes to trigger recompilation +#define KKLIB_BUILD 97 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks @@ -896,11 +896,17 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { /*---------------------------------------------------------------------- ----------------------------------------------------------------------*/ +#if !defined(KK_BOX_PTR_SHIFT) +#define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) +#endif static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); #if KK_COMPRESS intptr_t i = (intptr_t)p - ctx->heap_base; + #if KK_BOX_PTR_SHIFT > 0 + i = kk_sarp(i, KK_BOX_PTR_SHIFT); + #endif kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); return _kk_make_ptr((kk_intb_t)i); #else @@ -912,7 +918,11 @@ static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { kk_assert_internal(kk_is_ptr(b)); #if KK_COMPRESS - intptr_t i = ctx->heap_base + _kk_unmake_ptr(b); + intptr_t i = _kk_unmake_ptr(b); + #if KK_BOX_PTR_SHIFT > 0 + i = kk_shlp(i, KK_BOX_PTR_SHIFT); + #endif + i = i + ctx->heap_base; return (kk_ptr_t)i; #else kk_unused(ctx); diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index f67ab1eae..9e64be176 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -409,10 +409,6 @@ typedef uint32_t kk_uintb_t; #error "the given platform boxed integer size is (currently) not supported" #endif -#if !defined(KK_BOX_PTR_SHIFT) -#define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - 1) -#endif - // Largest natural integer that fits into a boxed value #if (KK_INTB_SIZE > KK_SIZE_SIZE) // ensure it fits the natural register size diff --git a/kklib/src/init.c b/kklib/src/init.c index 640fb46b7..28c085e46 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -222,7 +222,7 @@ kk_context_t* kk_get_context(void) { #if KK_INTF_SIZE==4 && KK_COMPRESS && defined(KK_MIMALLOC) #if defined(KK_MIMALLOC) mi_arena_id_t arena; - kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8); // +KK_BOX_PTR_SHIFT); + kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8 + KK_BOX_PTR_SHIFT); int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); if (err != 0) { kk_fatal_error(err, "unable to reserve the initial heap"); diff --git a/lib/std/num/float64-inline.c b/lib/std/num/float64-inline.c index 5918630bd..cd1e36b17 100644 --- a/lib/std/num/float64-inline.c +++ b/lib/std/num/float64-inline.c @@ -17,7 +17,7 @@ static inline double kk_double_from_bits( int64_t i, kk_context_t* ctx ) { } static inline double kk_prim_parse_double( kk_string_t str, kk_context_t* ctx) { - const char* s = kk_string_cbuf_borrow(str,NULL); + const char* s = kk_string_cbuf_borrow(str,NULL,ctx); char* end; double d = strtod(s,&end); kk_string_drop(str,ctx); From 5e035308a59954a3188044f3e6a157bd19525fe3 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 7 Dec 2022 17:30:50 -0800 Subject: [PATCH 094/233] fix borrowed value unboxing by dupping upfront --- kklib/include/kklib.h | 2 +- kklib/include/kklib/platform.h | 2 +- src/Backend/C/FromCore.hs | 7 ++++--- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 7d40e3bb5..edd993e6b 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1075,7 +1075,7 @@ static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t, static inline void kk_datatype_ptr_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); - kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); + // kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); kk_datatype_ptr_drop(d, ctx); } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 9e64be176..473c5a10b 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -372,7 +372,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE +#define KK_INTB_SIZE KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 2edc23ab1..48c418476 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1456,17 +1456,18 @@ genPatternTest doTest gfree (exprDoc,pattern) -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon -> do local <- newVarName "unbox" - let unbox = genBoxCall "unbox" True targ exprDoc + let assign = ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi + unbox = genBoxCall "unbox" False {-True-} targ (ppDefName local) next = genNextPatterns (\self fld -> self) {-(ppDefName local)-} unbox targ [pattern] -- assign = ppType targ <+> ppDefName local <+> text "=" <+> unbox <.> semi - return [([],[{-assign-}],next)] + return [([],[assign],next)] PatVar tname pattern -> do let after = if (patternVarFree pattern && not (tnamesMember tname gfree)) then [] else [ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi] next = genNextPatterns (\self fld -> self) (ppDefName (getName tname)) (typeOf tname) [pattern] return [([],after,next)] PatLit (LitString s) - -> return [(test [text "kk_string_cmp_cstr_borrow" <.> tupled [exprDoc,fst (cstring s)] <+> text "== 0"],[],[])] + -> return [(test [text "kk_string_cmp_cstr_borrow" <.> arguments [exprDoc,fst (cstring s)] <+> text "== 0"],[],[])] PatLit lit@(LitInt _) -> return [(test [text "kk_integer_eq_borrow" <.> arguments [exprDoc,ppLit lit]],[],[])] PatLit lit From 4bab2611e4adde7a2c620459a7bd41f9f7bef8ac Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 8 Dec 2022 15:38:08 -0800 Subject: [PATCH 095/233] fix seg faults due to non-packed structs --- kklib/include/kklib.h | 70 +++++++++++++++++-------------- kklib/include/kklib/box.h | 2 +- kklib/include/kklib/platform.h | 76 ++++++++++++++++++++-------------- kklib/src/refcount.c | 2 + src/Backend/C/FromCore.hs | 12 +++--- 5 files changed, 93 insertions(+), 69 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index edd993e6b..aa0f9ba8c 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 97 // modify on changes to trigger recompilation +#define KKLIB_BUILD 96 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks @@ -268,6 +268,27 @@ static inline kk_decl_pure kk_ssize_t kk_block_scan_fsize(const kk_block_t* b) { return (kk_ssize_t)kk_intf_unbox(bl->large_scan_fsize); } +static inline void kk_block_set_invalid(kk_block_t* b) { +#ifdef KK_DEBUG_FULL + const kk_ssize_t scan_fsize = kk_block_scan_fsize(b); + const kk_ssize_t bsize = (sizeof(kk_box_t) * scan_fsize) + (b->header.scan_fsize == KK_SCAN_FSIZE_MAX ? sizeof(kk_block_large_t) : sizeof(kk_block_t)); + uint8_t* p = (uint8_t*)b; + for (kk_ssize_t i = 0; i < bsize; i++) { + p[i] = 0xDF; + } +#else + kk_unused(b); +#endif +} + +static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { + return (b != NULL && ((uintptr_t)b & 1) == 0 && *((uint64_t*)b) != KK_U64(0xDFDFDFDFDFDFDFDF) // already freed! + && (b->header.tag > KK_TAG_MAX || b->header.tag < 0xFF) + && (b->header._field_idx <= b->header.scan_fsize) + ); +} + + static inline kk_decl_pure kk_refcount_t kk_block_refcount(const kk_block_t* b) { return kk_atomic_load_relaxed(&b->header.refcount); } @@ -290,6 +311,7 @@ typedef struct kk_block_fields_s { } kk_block_fields_t; static inline kk_decl_pure kk_box_t kk_block_field(kk_block_t* b, kk_ssize_t index) { + kk_assert_internal(kk_block_is_valid(b)); kk_block_fields_t* bf = (kk_block_fields_t*)b; // must overlap with datatypes with scanned fields. return bf->fields[index]; } @@ -314,22 +336,6 @@ static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { } -static inline void kk_block_set_invalid(kk_block_t* b) { -#ifdef KK_DEBUG_FULL - const kk_ssize_t scan_fsize = kk_block_scan_fsize(b); - const kk_ssize_t bsize = (sizeof(kk_box_t) * scan_fsize) + (b->header.scan_fsize == KK_SCAN_FSIZE_MAX ? sizeof(kk_block_large_t) : sizeof(kk_block_t)); - uint8_t* p = (uint8_t*)b; - for (kk_ssize_t i = 0; i < bsize; i++) { - p[i] = 0xDF; - } -#else - kk_unused(b); -#endif -} - -static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { - return (b != NULL && ((uintptr_t)b & 1) == 0 && *((uint64_t*)b) != KK_U64(0xDFDFDFDFDFDFDFDF)); // already freed! -} @@ -339,17 +345,20 @@ static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { be (usually) accessed efficiently through a register. --------------------------------------------------------------------------------------*/ #ifdef KK_MIMALLOC -#if !defined(MI_MAX_ALIGN_SIZE) -# define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE -#endif -#ifdef KK_MIMALLOC_INLINE -#include "../mimalloc/include/mimalloc-inline.h" -#else -#include "../mimalloc/include/mimalloc.h" -#endif -typedef mi_heap_t* kk_heap_t; + #if !defined(MI_MAX_ALIGN_SIZE) + #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #endif + #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) + #define MI_DEBUG 3 + #endif + #ifdef KK_MIMALLOC_INLINE + #include "../mimalloc/include/mimalloc-inline.h" + #else + #include "../mimalloc/include/mimalloc.h" + #endif + typedef mi_heap_t* kk_heap_t; #else -typedef void* kk_heap_t; + typedef void* kk_heap_t; #endif // A function has as its first field a pointer to a C function that takes the @@ -934,6 +943,7 @@ static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { #define KK_INTF_BOX_MAX ((kk_intf_t)KK_INTF_MAX >> (KK_INTF_BITS - KK_INTF_BOX_BITS)) #define KK_INTF_BOX_MIN (- KK_INTF_BOX_MAX - 1) + static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { kk_assert_internal(extra_shift >= 0); kk_assert_internal(i >= (KK_INTF_BOX_MIN / (KK_IF(1)<= 0); - kk_assert_internal(kk_is_value(b)); + kk_assert_internal(kk_is_value(b) || b == kk_get_context()->kk_box_any.dbox); kk_intb_t i = kk_sarb(_kk_unmake_value(b),KK_TAG_BITS + extra_shift); return (kk_intf_t)i; } @@ -1074,8 +1084,8 @@ static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t, } static inline void kk_datatype_ptr_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { - kk_unused_internal(t); - // kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); + kk_unused(t); + kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx) || kk_datatype_ptr_has_tag(d, KK_TAG_BOX_ANY, ctx)); kk_datatype_ptr_drop(d, ctx); } diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 8f5be3d9d..952d0c3d7 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -400,7 +400,7 @@ static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { f = f - (intptr_t)&kk_main_start; #endif kk_assert(kk_shrp(f, KK_INTPTR_BITS - 1) == 0); // assume top bit of function pointer addresses is clear - kk_assert(f >= KK_INTF_MIN && f <= KK_INTF_MAX); + kk_assert(f >= KK_INTF_BOX_MIN && f <= KK_INTF_BOX_MAX); kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value return b; } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 473c5a10b..a90ff5e32 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -145,12 +145,16 @@ #if defined(__GNUC__) #pragma GCC diagnostic ignored "-Wunused-variable" #pragma GCC diagnostic ignored "-Wunused-value" -#pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals -#define kk_decl_const __attribute__((const)) // reads no global state at all -#define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects -#define kk_decl_noinline __attribute__((noinline)) -#define kk_decl_align(a) __attribute__((aligned(a))) -#define kk_decl_thread __thread +#pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals +#pragma GCC diagnostic ignored "-Waddress-of-packed-member" +#define kk_decl_const __attribute__((const)) // reads no global state at all +#define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects +#define kk_decl_noinline __attribute__((noinline)) +#define kk_decl_align(a) __attribute__((aligned(a))) +#define kk_decl_thread __thread +#define kk_struct_packed struct __attribute__((__packed__)) +#define kk_struct_packed_end +#define KK_HAS_STRUCT_PACKING 1 #elif defined(_MSC_VER) #pragma warning(disable:4214) // using bit field types other than int #pragma warning(disable:4101) // unreferenced local variable @@ -160,9 +164,12 @@ #pragma warning(disable:26812) // the enum type is unscoped (in C++) #define kk_decl_const #define kk_decl_pure -#define kk_decl_noinline __declspec(noinline) -#define kk_decl_align(a) __declspec(align(a)) -#define kk_decl_thread __declspec(thread) +#define kk_decl_noinline __declspec(noinline) +#define kk_decl_align(a) __declspec(align(a)) +#define kk_decl_thread __declspec(thread) +#define kk_struct_packed __pragma(pack(push,1)) struct +#define kk_struct_packed_end __pragma(pack(pop)) +#define KK_HAS_STRUCT_PACKING 1 #ifndef __cplusplus #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif @@ -171,7 +178,10 @@ #define kk_decl_pure #define kk_decl_noinline #define kk_decl_align(a) -#define kk_decl_thread __thread +#define kk_decl_thread __thread +#define kk_struct_packed struct +#define kk_struct_packed_end +#define KK_HAS_STRUCT_PACKING 0 #endif #if defined(__GNUC__) || defined(__clang__) @@ -362,21 +372,20 @@ typedef unsigned kk_uintx_t; // We have |kk_intf_t| <= |kk_box_t| <= |intptr_t|. // These are generally all the same size, on x64 they will all be 64-bit. // But not always: -// - |kk_intf_t| can be smaller than |kk_box_t| if pointers are larger than natural ints (say x86 huge) +// - |kk_intf_t| can be smaller than |kk_box_t| if pointers are larger than natural ints (say x86 huge, or CHERI) // - |kk_box_t| can be smaller than |intptr_t| if pointers are compressed. // For example using a compressed heap with 32-bit pointers on a 64-bit system, or // 64-bit addresses on a 128-bit CHERI system. // // The `kk_intf_t` represents the largest integer size that fits into `kk_box_t` (minus 1 bit) -// but not larger than the natural register size for integers. +// but which is not larger than the natural register size for integers. // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE KK_INTPTR_SIZE +#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) - // define `kk_intb_t` (the integer that can hold a boxed value) #if (KK_INTB_SIZE == KK_INTPTR_SIZE) #define KK_COMPRESS 0 @@ -409,6 +418,9 @@ typedef uint32_t kk_uintb_t; #error "the given platform boxed integer size is (currently) not supported" #endif +#if KK_COMPRESS && !KK_HAS_STRUCT_PACKING +#error "pointer compression can only be used with C compilers that support struct packing" +#endif // Largest natural integer that fits into a boxed value #if (KK_INTB_SIZE > KK_SIZE_SIZE) // ensure it fits the natural register size @@ -432,26 +444,26 @@ typedef kk_uintb_t kk_uintf_t; // Distinguish unsigned shift right and signed arithmetic shift right. // (Here we assume >> is arithmetic right shift). Avoid UB by always masking the shift. -static inline kk_intx_t kk_sar(kk_intx_t i, int shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_uintx_t kk_shr(kk_uintx_t u, int shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_sarf(kk_intf_t i, int shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } -static inline kk_uintf_t kk_shrf(kk_uintf_t u, int shift) { return (u >> (shift & (KK_INTF_BITS - 1))); } -static inline kk_intb_t kk_sarb(kk_intb_t i, int shift) { return (i >> (shift & (KK_INTB_BITS - 1))); } - -static inline uintptr_t kk_shrp(uintptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } -static inline intptr_t kk_sarp(intptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } -static inline int32_t kk_sar32(int32_t i, int shift) { return (i >> (shift & 31)); } -static inline uint32_t kk_shr32(uint32_t u, int shift) { return (u >> (shift & 31)); } -static inline int64_t kk_sar64(int64_t i, int shift) { return (i >> (shift & 63)); } -static inline uint64_t kk_shr64(uint64_t u, int shift) { return (u >> (shift & 63)); } +static inline kk_intx_t kk_sar(kk_intx_t i, int shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_uintx_t kk_shr(kk_uintx_t u, int shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_sarf(kk_intf_t i, int shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_uintf_t kk_shrf(kk_uintf_t u, int shift) { return (u >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_sarb(kk_intb_t i, int shift) { return (i >> (shift & (KK_INTB_BITS - 1))); } + +static inline uintptr_t kk_shrp(uintptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline intptr_t kk_sarp(intptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_sar32(int32_t i, int32_t shift) { return (i >> (shift & 31)); } +static inline uint32_t kk_shr32(uint32_t u, int32_t shift) { return (u >> (shift & 31)); } +static inline int64_t kk_sar64(int64_t i, int64_t shift) { return (i >> (shift & 63)); } +static inline uint64_t kk_shr64(uint64_t u, int64_t shift) { return (u >> (shift & 63)); } // Avoid UB by left shifting on unsigned integers (and masking the shift). -static inline kk_intx_t kk_shl(kk_intx_t i, int shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_shlf(kk_intf_t i, int shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } -static inline kk_intb_t kk_shlb(kk_intb_t i, int shift) { return (kk_intb_t)((kk_uintb_t)i << (shift & (KK_INTB_BITS - 1))); } -static inline intptr_t kk_shlp(intptr_t i, int shift) { return (intptr_t)((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } -static inline int32_t kk_shl32(int32_t i, int shift) { return (int32_t)((uint32_t)i << (shift & 31)); } -static inline int64_t kk_shl64(int64_t i, int shift) { return (int64_t)((uint64_t)i << (shift & 63)); } +static inline kk_intx_t kk_shl(kk_intx_t i, int shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_shlf(kk_intf_t i, int shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_shlb(kk_intb_t i, int shift) { return (kk_intb_t)((kk_uintb_t)i << (shift & (KK_INTB_BITS - 1))); } +static inline intptr_t kk_shlp(intptr_t i, int shift) { return (intptr_t)((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_shl32(int32_t i, int32_t shift) { return (int32_t)((uint32_t)i << (shift & 31)); } +static inline int64_t kk_shl64(int64_t i, int64_t shift) { return (int64_t)((uint64_t)i << (shift & 63)); } diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index ff10c7dc9..f9f4d41b0 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -240,6 +240,7 @@ static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t f kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { kk_block_t* child = kk_ptr_unbox(v,ctx); + kk_assert_internal(kk_block_is_valid(child)); if (kk_block_decref_no_free(child)) { uint8_t v_scan_fsize = child->header.scan_fsize; if (v_scan_fsize == 0) { // free leaf nodes directly and pretend it was not a ptr field @@ -286,6 +287,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t // ------- drop the children and free the block b ------------ move_down: + kk_assert_internal(kk_block_is_valid(b)); scan_fsize = b->header.scan_fsize; kk_assert_internal(kk_block_refcount(b) == 0); kk_assert_internal(scan_fsize > 0); // due to kk_block_should_free diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 48c418476..92be66232 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -499,14 +499,14 @@ genTypeDefPost (Data info isExtend) else if (dataRepr == DataEnum || not (dataReprIsValue dataRepr)) then return () else emitToH $ if (hasTagField dataRepr) - then ppVis (dataInfoVis info) <.> text "struct" <+> ppName name <.> text "_s" + then ppVis (dataInfoVis info) <.> text "kk_struct_packed" <+> ppName name <.> text "_s" <+> block (text "kk_value_tag_t _tag;" <-> text "union" <+> block (vcat ( map ppStructConField (dataInfoConstrs info) ++ (if (maxScanCount > 0 && minScanCount /= maxScanCount) then [text "kk_box_t _fields[" <.> pretty maxScanCount <.> text "];"] else []) - )) <+> text "_cons;") <.> semi + )) <+> text "_cons;") <.> semi <-> text "kk_struct_packed_end" <-> ppVis (dataInfoVis info) <.> text "typedef struct" <+> ppName name <.> text "_s" <+> ppName (typeClassName name) <.> semi else ppVis (dataInfoVis info) <.> text "typedef struct" <+> (case (dataRepr,dataInfoConstrs info) of @@ -546,10 +546,10 @@ genConstructorType info dataRepr (con,conRepr,conFields,scanCount) = -> return () -- represented as an enum -- _ | null conFields && (dataRepr < DataNormal && not (isDataStructLike dataRepr)) -- -> return () - _ -> do emitToH $ ppVis (conInfoVis con) <.> text "struct" <+> ppName ((conInfoName con)) <+> + _ -> do emitToH $ ppVis (conInfoVis con) <.> text "kk_struct_packed" <+> ppName ((conInfoName con)) <+> block (let fields = (typeField ++ map ppConField conFields) in if (null fields) then text "kk_box_t _unused;" -- avoid empty struct - else vcat fields) <.> semi + else vcat fields) <.> semi <-> text "kk_struct_packed_end" where typeField = if (dataReprIsValue dataRepr) then [] else [text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s" <+> text "_base;"] @@ -1085,10 +1085,10 @@ genLambda params eff body platform <- getPlatform let (fields,_,scanCount) = orderConFieldsEx platform newtypes False freeVars fieldDocs = [ppType tp <+> ppName name | (name,tp) <- fields] - tpDecl = text "struct" <+> ppName funTpName <+> block ( + tpDecl = text "kk_struct_packed" <+> ppName funTpName <+> block ( vcat ([text "struct kk_function_s _base;"] ++ [ppType tp <+> ppName name <.> semi | (name,tp) <- fields]) - ) <.> semi + ) <.> semi <-> text "kk_struct_packed_end" funSig = text (if toH then "extern" else "static") <+> ppType (typeOf body) <+> ppName funName <.> parameters ([text "kk_function_t _fself"] ++ From bb190493164c05b101764c04682e8ff46263cf93 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 8 Dec 2022 16:09:37 -0800 Subject: [PATCH 096/233] fix multithreaded execution with each thread local heap attached to a single arena --- kklib/include/kklib.h | 16 ++++++++++------ kklib/src/init.c | 37 +++++++++++++++++++++++-------------- kklib/src/integer.c | 8 ++++---- 3 files changed, 37 insertions(+), 24 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index aa0f9ba8c..039872bcd 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 96 // modify on changes to trigger recompilation +#define KKLIB_BUILD 97 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks @@ -171,8 +171,6 @@ typedef struct kk_integer_s { kk_intb_t ibox; } kk_integer_t; - - // A general datatype with constructors and singletons is either // an enumeration (with the lowest bit set as: 4*tag + 1) or a `kk_block_t*` pointer. // Isomorphic with boxed values. @@ -305,6 +303,11 @@ static inline kk_decl_pure bool kk_block_is_thread_shared(const kk_block_t* b) { return kk_unlikely(kk_refcount_is_thread_shared(kk_block_refcount(b))); } +// Used to generically inspect the scannable fields of an object as used +// to recursively free data, or mark as shared. This must overlay with +// any heap block and if pointer compression is used we need to use packed +// structures to avoid any potential padding in a struct (at least up to +// the first `scan_fsize` fields) typedef struct kk_block_fields_s { kk_block_t _block; kk_box_t fields[1]; @@ -336,9 +339,6 @@ static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { } - - - /*-------------------------------------------------------------------------------------- The thread local context as `kk_context_t` This is passed by the code generator as an argument to every function so it can @@ -1157,12 +1157,16 @@ static inline kk_box_t kk_datatype_ptr_box(kk_datatype_t d) { } static inline kk_datatype_t kk_datatype_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(ctx); + kk_unused_internal(t); kk_datatype_t d = kk_datatype_unbox(b); kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); return d; } static inline kk_datatype_t kk_datatype_ptr_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(ctx); + kk_unused_internal(t); kk_datatype_t d = kk_datatype_ptr_unbox(b); kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); return d; diff --git a/kklib/src/init.c b/kklib/src/init.c index 28c085e46..a09636157 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -146,6 +146,16 @@ void kk_info_message(const char* fmt, ...) { --------------------------------------------------------------------------------------------------*/ static bool process_initialized; // = false +#if KK_COMPRESS + #if defined(KK_MIMALLOC) + #define KK_USE_MEM_ARENA 1 + static mi_arena_id_t arena; + static intptr_t arena_base; + #else + #error "can only use compressed heaps with the mimalloc allocator enabled" + #endif +#endif + static void kklib_done(void) { if (!process_initialized) return; kk_free_context(); @@ -183,6 +193,17 @@ static void kklib_init(void) { kk_has_tzcnt = ((cpu_info[1] & (KK_I32(1)<<3)) != 0); // bmi1: https://en.wikipedia.org/wiki/X86_Bit_manipulation_instruction_set #endif atexit(&kklib_done); + + #if KK_USE_MEM_ARENA + const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8 + KK_BOX_PTR_SHIFT); + int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); + if (err != 0) { + kk_fatal_error(err, "unable to reserve the initial heap"); + } + size_t arena_size; + void* arena_start = mi_arena_area(arena, &arena_size); + arena_base = (intptr_t)arena_start + (intptr_t)(arena_size / 2); + #endif } /*-------------------------------------------------------------------------------------------------- @@ -219,23 +240,11 @@ kk_context_t* kk_get_context(void) { kk_context_t* ctx = context; if (ctx!=NULL) return ctx; kklib_init(); -#if KK_INTF_SIZE==4 && KK_COMPRESS && defined(KK_MIMALLOC) -#if defined(KK_MIMALLOC) - mi_arena_id_t arena; - kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8 + KK_BOX_PTR_SHIFT); - int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); - if (err != 0) { - kk_fatal_error(err, "unable to reserve the initial heap"); -} +#if KK_USE_MEM_ARENA mi_heap_t* heap = mi_heap_new_in_arena(arena); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); kk_assign_const(kk_heap_t,ctx->heap) = heap; - size_t arena_size; - void* arena_base = mi_arena_area(arena, &arena_size); - kk_assign_const(intptr_t,ctx->heap_base) = (intptr_t)arena_base + (intptr_t)(arena_size / 2); -#else -#error "can only use compressed heaps with the mimalloc allocator enabled" -#endif + kk_assign_const(intptr_t, ctx->heap_base) = arena_base; #elif defined(KK_MIMALLOC) mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); diff --git a/kklib/src/integer.c b/kklib/src/integer.c index 2bde30aa3..f5de9bc47 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -343,7 +343,7 @@ static kk_bigint_t* bigint_from_int(kk_intx_t i, kk_context_t* ctx) { u = (kk_uintx_t)i; } else if (i == KK_INTX_MIN) { - u = ((KK_UINTX_MAX)/2) + KK_UX(1); + u = KK_INTX_MAX; u++; // avoid compiler warning on msvc } else { u = (kk_uintx_t)(-i); @@ -363,7 +363,7 @@ static kk_bigint_t* bigint_from_int64(int64_t i, kk_context_t* ctx) { u = (uint64_t)i; } else if (i == INT64_MIN) { - u = (UINT64_MAX/2) + KK_U64(1); + u = INT64_MAX; u++; // avoid compiler warning on msvc } else { u = (uint64_t)(-i); @@ -1594,9 +1594,9 @@ static kk_intf_t int_count_digits(kk_intf_t x) { return kk_bits_digits(u); } -static kk_intf_t bigint_count_digits(kk_bigint_t* x, kk_context_t* ctx) { +static kk_intx_t bigint_count_digits(kk_bigint_t* x, kk_context_t* ctx) { kk_assert_internal(x->count > 0); - kk_intf_t count; + kk_intx_t count; #if (DIGIT_BITS==64) count = kk_bits_digits64(x->digits[x->count-1]) + LOG_BASE*(x->count - 1); #else From 4de4139579df2d2ae9e4e076060337d3bb91f0e7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 8 Dec 2022 16:31:07 -0800 Subject: [PATCH 097/233] fix regex module c code --- lib/std/text/regex-inline.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index 3b8a087e2..2b7c95a5d 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -75,7 +75,7 @@ static void kk_regex_free( void* pre, kk_block_t* b, kk_context_t* ctx ) { static kk_box_t kk_regex_create( kk_string_t pat, bool ignore_case, bool multi_line, kk_context_t* ctx ) { kk_ssize_t len; - const uint8_t* cpat = kk_string_buf_borrow( pat, &len ); + const uint8_t* cpat = kk_string_buf_borrow( pat, &len, ctx ); PCRE2_SIZE errofs = 0; int errnum = 0; uint32_t options = KK_REGEX_OPTIONS; @@ -119,7 +119,7 @@ static kk_std_core__list kk_regex_exec_ex( pcre2_code* re, pcre2_match_data* mat kk_ssize_t sstart = groups[i*2]; // on no-match, sstart and send == -1. kk_ssize_t send = groups[i*2 + 1]; kk_assert(send >= sstart); - kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow), sstart, send - sstart, ctx ); + kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow,ctx), sstart, send - sstart, ctx ); hd = kk_std_core__new_Cons(kk_reuse_null,kk_std_core__sslice_box(sslice,ctx), hd, ctx); if (i == 0) { if (mstart != NULL) { *mstart = sstart; } @@ -136,13 +136,13 @@ static kk_std_core__list kk_regex_exec( kk_box_t bre, kk_string_t str, kk_ssize_ // unpack pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,ctx); kk_ssize_t len = 0; const uint8_t* cstr = NULL; if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; - cstr = kk_string_buf_borrow(str, &len ); + cstr = kk_string_buf_borrow(str, &len, ctx ); // and match res = kk_regex_exec_ex( re, match_data, str, cstr, len, true, start, NULL, NULL, NULL, ctx ); @@ -162,13 +162,13 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (atmost < 0) atmost = KK_SSIZE_MAX; pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,ctx); if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; { kk_ssize_t len; - const uint8_t* cstr = kk_string_buf_borrow(str, &len ); + const uint8_t* cstr = kk_string_buf_borrow(str, &len, ctx ); // and match kk_std_core__list* tail = NULL; @@ -183,13 +183,13 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (rc > 0) { // found a match; // push string up to match, and the actual matched regex - kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str), start, mstart - start, ctx ); + kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str,ctx), start, mstart - start, ctx ); kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(prelist,ctx), capcons, ctx ); if (tail==NULL) res = cons; else *tail = cons; - tail = &kk_std_core__as_Cons(capcons)->tail; + tail = &kk_std_core__as_Cons(capcons,ctx)->tail; allow_empty = (next > start); start = next; } @@ -204,7 +204,7 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss } // push final string part as well and end the list - kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str), next, len - next, ctx ); + kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str,ctx), next, len - next, ctx ); kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); if (tail==NULL) res = cons; From ea0591fdbfa840fb6cc1c53f9d984d7bd6a5dbd9 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 9 Dec 2022 10:32:00 -0800 Subject: [PATCH 098/233] stop generating scan_count but use the max for value types --- src/Backend/C/FromCore.hs | 13 +++++++------ src/Kind/Infer.hs | 10 +++++----- test/cgen/data1.kk | 13 ++++++------- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 92be66232..cf6bae90c 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -708,7 +708,7 @@ genConstructorBaseCast info dataRepr con conRepr <.> parameters [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] <+> block ( let base = text "&_x->_base" - in text "return" <+> text "kk_datatype_from_base" <+> arguments [base] <.> semi + in text "return" <+> text "kk_datatype_from_base" <.> arguments [base] <.> semi ) @@ -725,7 +725,7 @@ genConstructorAccess info dataRepr con conRepr text "return" <+> text "kk_datatype_as_assert" <.> arguments [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", - (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr <+> text "/* _tag */")] <.> semi] + (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr)] <.> semi] ) @@ -775,10 +775,11 @@ genBox name info dataRepr ) _ -> case dataInfoDef info of DataDefValue raw scancount - -> let -- extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors - docScanCount = if (hasTagField dataRepr) + -> let extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors + docScanCount = {- if (hasTagField dataRepr) then ppName name <.> text "_scan_count" <.> arguments [text "_x"] - else pretty scancount <+> text "/* scan count */" + else -} + pretty (scancount + extra) <+> text "/* scan count */" in vcat [ text "kk_box_t _box;" , text "kk_valuetype_box" <.> arguments [ppName name, text "_box", text "_x", docScanCount @@ -829,7 +830,7 @@ genUnbox name info dataRepr genDupDrop :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genDupDrop name info dataRepr conInfos - = do genScanFields name info dataRepr conInfos + = do -- genScanFields name info dataRepr conInfos genDupDropX True name info dataRepr conInfos genDupDropX False name info dataRepr conInfos when (not (dataReprIsValue dataRepr)) $ diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index b2a15c056..3f405d0fd 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -931,11 +931,11 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort do if (isVal) then -- addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors which varying raw types and regular types." <-> -- text "hint: value types with multiple constructors must all use the same number of regular types when mixed with raw types (use 'box' to use a raw type as a regular type).") - addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors with a different number of regular types." <-> - text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") - else return () - trace ("cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ - return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) + addError range (text "type:" <+> nameDoc <+> text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") + else addWarning range (text "type:" <+> nameDoc <+> text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") + -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ + return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) _ -> return DataDefNormal sumDataDefs :: Doc -> [DataDef] -> KInfer (Int,Int) diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index 007172130..dadd20772 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -9,10 +9,6 @@ | DataOpen */ -extern import { - c "" -} - // enum type void @@ -39,8 +35,11 @@ type list { Cons(x:a,tail:list); Nil } // single normal type single-normal { Single-normal( x:a, y:maybe, z:pair ); Single-normal-extra() } +// struct (as normal) +type vstrct { VStrct( x:a, i:int ); VStrct2(d:float64,s:string); VStrct3(i:int32) } + // struct -type strct { Strct( x:a, i:int ); Strct2(d:float64,s:string); Strct3(i:int32) } +type strct { Strct( x:a, i:int ); Strct2(i:int, s:string); Strct3(x:a) } // struct type maybe { Just(x:a); Nothing } @@ -50,9 +49,9 @@ type normal { One(x:a,y:pair,z:pair); Two(x:int); Three } // open -type open open { Open1(:a) } +open type open { Open1(:a) } -// type extend open { Open2(:int) } +extend type open { Open2(:int) } // mixed raw / scan type point { Point(x:float64,y:float64,z:int) } From 3fad8bb07f95ed86ce2d970f6b9d5f830242bc77 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 9 Dec 2022 11:03:40 -0800 Subject: [PATCH 099/233] improve valuetype unbox codegen --- kklib/include/kklib/box.h | 25 +++++++++++++++++-------- src/Backend/C/FromCore.hs | 12 ++---------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 952d0c3d7..b5a6bf86c 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -325,20 +325,29 @@ typedef struct kk_boxed_value_s { intptr_t data; } * kk_boxed_value_t; -#define kk_valuetype_unbox_(tp,p,x,box,ctx) \ +static inline void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx) { + const size_t max_scan_fsize = size / sizeof(kk_box_t); + for (size_t i = 0; i < max_scan_fsize; i++) { + p[i] = kk_box_any(ctx); + } + kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); +} + +#define kk_valuetype_unbox_(tp,x,box,ctx) \ do { \ if kk_unlikely(kk_box_is_any(box)) { \ - p = NULL; \ - const size_t kk__max_scan_fsize = sizeof(tp)/sizeof(kk_box_t); \ - kk_box_t* _fields = (kk_box_t*)(&x); \ - for (size_t i = 0; i < kk__max_scan_fsize; i++) { _fields[i] = kk_box_any(ctx); } \ - kk_block_decref(kk_block_unbox(box,KK_TAG_BOX_ANY,ctx),ctx); \ + kk_valuetype_unbox_from_any((kk_box_t*)&x, sizeof(tp), box, ctx); \ } \ else { \ - p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ + kk_boxed_value_t p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ - } \ + /* if (!borrow) { */ \ + if (kk_base_type_is_unique(p)) { kk_base_type_free(p,ctx); } else { \ + else { tp##_dup(x,ctx); kk_base_type_decref(p,ctx); } \ + /* } */ \ + }\ } while(0) + #define kk_valuetype_box(tp,x,val,scan_fsize,ctx) \ do { \ diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index cf6bae90c..e6f617916 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -808,16 +808,8 @@ genUnbox name info dataRepr ] <.> semi ) _ | dataReprIsValue dataRepr - -> vcat [ text "kk_boxed_value_t _p;" - , ppName name <+> text "_unbox;" - , text "kk_valuetype_unbox_" <.> arguments [ppName name, text "_p", text "_unbox", text "_x"] <.> semi -- borrowing - , text "if (_ctx!=NULL && _p!=NULL)" <+> block ( - text "if (kk_base_type_is_unique(_p)) { kk_base_type_free(_p,_ctx); } else" <+> block ( - vcat [ppName name <.> text "_dup(_unbox,_ctx);" - ,text "kk_base_type_decref" <.> arguments [text "_p"] <.> semi] - ) - ) - -- , text "else {" <+> ppName name <.> text "_dup(_unbox); }" + -> vcat [ ppName name <+> text "_unbox;" + , text "kk_valuetype_unbox_" <.> arguments [ppName name, text "_unbox", text "_x"] <.> semi , text "return _unbox" ] -- text "unbox_valuetype" <.> arguments [ppName name, text "x"] _ -> text "return" From 4b076c30c234d19ec482a50be056e03e212f4628 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 9 Dec 2022 12:52:27 -0800 Subject: [PATCH 100/233] nicer codegen for dupdrop tests --- kklib/include/kklib.h | 2 +- kklib/include/kklib/box.h | 30 ++++---- kklib/include/kklib/platform.h | 2 +- kklib/src/box.c | 11 +++ src/Backend/C/FromCore.hs | 127 ++++++++++++++++++++++++++------- 5 files changed, 125 insertions(+), 47 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 039872bcd..19e559a6c 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 97 // modify on changes to trigger recompilation +#define KKLIB_BUILD 98 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index b5a6bf86c..c1fe36a8a 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -315,6 +315,12 @@ static inline kk_box_t kk_box_unbox(kk_box_t b, kk_context_t* ctx) { return b; } +// `box_any` is used to return when yielding +// (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) +static inline kk_box_t kk_box_any(kk_context_t* ctx) { + kk_datatype_ptr_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); + return kk_datatype_ptr_box(ctx->kk_box_any); +} /*---------------------------------------------------------------- Generic boxing of value types @@ -325,15 +331,10 @@ typedef struct kk_boxed_value_s { intptr_t data; } * kk_boxed_value_t; -static inline void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx) { - const size_t max_scan_fsize = size / sizeof(kk_box_t); - for (size_t i = 0; i < max_scan_fsize; i++) { - p[i] = kk_box_any(ctx); - } - kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); -} -#define kk_valuetype_unbox_(tp,x,box,ctx) \ +kk_decl_export void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx); + +#define kk_valuetype_unbox(tp,x,box,ctx) \ do { \ if kk_unlikely(kk_box_is_any(box)) { \ kk_valuetype_unbox_from_any((kk_box_t*)&x, sizeof(tp), box, ctx); \ @@ -341,9 +342,9 @@ static inline void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_ else { \ kk_boxed_value_t p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ - /* if (!borrow) { */ \ - if (kk_base_type_is_unique(p)) { kk_base_type_free(p,ctx); } else { \ - else { tp##_dup(x,ctx); kk_base_type_decref(p,ctx); } \ + /* if (ctx!=NULL) { */ \ + if (kk_base_type_is_unique(p)) { kk_base_type_free(p,ctx); } \ + else { tp##_dup(x,ctx); kk_base_type_decref(p,ctx); } \ /* } */ \ }\ } while(0) @@ -357,13 +358,6 @@ static inline void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_ x = kk_base_type_box(p,ctx); \ } while(0) -// `box_any` is used to return when yielding -// (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) -static inline kk_box_t kk_box_any(kk_context_t* ctx) { - kk_datatype_ptr_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); - return kk_datatype_ptr_box(ctx->kk_box_any); -} - /*---------------------------------------------------------------- diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index a90ff5e32..5389dfef8 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -382,7 +382,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE +#define KK_INTB_SIZE KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) diff --git a/kklib/src/box.c b/kklib/src/box.c index 473920254..51b8d8785 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -7,6 +7,17 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" +/*---------------------------------------------------------------- + Value type boxing +----------------------------------------------------------------*/ + +void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx) { + const size_t max_scan_fsize = size / sizeof(kk_box_t); + for (size_t i = 0; i < max_scan_fsize; i++) { + p[i] = kk_box_any(ctx); + } + kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); +} /*---------------------------------------------------------------- Integer boxing diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index e6f617916..f4687d25b 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -755,6 +755,12 @@ primName_t prim s = primName prim $ text $ primName prim d = d <.> text "_" <.> text prim +dataStructAsMaybeSplit :: [ConInfo] -> (ConInfo,ConInfo) +dataStructAsMaybeSplit [conInfo1,conInfo2] + = if (null (conInfoParams conInfo1)) then (conInfo1,conInfo2) else (conInfo2,conInfo1) +dataStructAsMaybeSplit _ + = failure $ "Backend.C.dataStructAsMaybeSplit: invalid constructors for a maybe like type" + genBox name info dataRepr = emitToH $ text "static inline kk_box_t " <.> ppName name <.> text "_box" <.> parameters [ppName name <+> text "_x"] <+> block ( @@ -764,14 +770,14 @@ genBox name info dataRepr (isoName,isoTp) = (head (conInfoParams conInfo)) in text "return" <+> genBoxCall "box" False isoTp (text "_x." <.> ppName (unqualify isoName)) <.> semi DataStructAsMaybe - -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) + -> let (conNothing,conJust) = dataStructAsMaybeSplit (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) - in text "if" <+> parens (conTestName conNothing <.> arguments [text "_x"]) <+> (text "return kk_box_Nothing();") + in text "if" <+> parens (conTestName conNothing <.> arguments [text "_x"]) <+> (text "{ return kk_box_Nothing(); }") <-> text " else" <+> ( let boxField = genBoxCall "box" False conJustFieldTp (text "_x._cons." <.> ppDefName (conInfoName conJust) <.> text "." <.> ppName (unqualify conJustFieldName)) - in text "return kk_box_Just" <.> arguments [boxField] <.> semi + in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) _ -> case dataInfoDef info of DataDefValue raw scancount @@ -800,16 +806,16 @@ genUnbox name info dataRepr -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) in text "if (kk_box_is_Nothing(_x))" <+> - text "return" <+> conCreateName (conInfoName conNothing) <.> arguments [] <.> semi + text "{ return" <+> conCreateName (conInfoName conNothing) <.> arguments [] <.> semi <+> text "}" <-> text " else" <+> ( - text "return" <+> conCreateName (conInfoName conJust) <.> arguments [ + text "{ return" <+> conCreateName (conInfoName conJust) <.> arguments [ genBoxCall "unbox" False conJustFieldTp (text "kk_unbox_Just" <.> arguments [text "_x"]) - ] <.> semi + ] <.> semi <+> text "}" ) _ | dataReprIsValue dataRepr -> vcat [ ppName name <+> text "_unbox;" - , text "kk_valuetype_unbox_" <.> arguments [ppName name, text "_unbox", text "_x"] <.> semi + , text "kk_valuetype_unbox" <.> arguments [ppName name, text "_unbox", text "_x"] <.> semi , text "return _unbox" ] -- text "unbox_valuetype" <.> arguments [ppName name, text "x"] _ -> text "return" @@ -820,11 +826,13 @@ genUnbox name info dataRepr ) <.> semi) +-- con infos are sorted with singletons first genDupDrop :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genDupDrop name info dataRepr conInfos = do -- genScanFields name info dataRepr conInfos genDupDropX True name info dataRepr conInfos genDupDropX False name info dataRepr conInfos + {- when (not (dataReprIsValue dataRepr)) $ do genHole name info dataRepr -- create "hole" of this type for TRMC when (not (isDataAsMaybe dataRepr)) $ @@ -834,8 +842,8 @@ genDupDrop name info dataRepr conInfos genDropReuseFun name info dataRepr -- drop, but if refcount==0 return the address of the block instead of freeing genDropNFun name info dataRepr -- drop with known number of scan fields genReuse name info dataRepr -- return the address of the block - - + -} +{- genIsUnique :: Name -> DataInfo -> DataRepr -> Asm () genIsUnique name info dataRepr = emitToH $ @@ -885,8 +893,9 @@ genHole name info dataRepr text "return" <+> -- holes must be trace-able and look like values (least-significant-bit==1) text "kk_datatype_null()" <.> semi) +-} - +{- genScanFields :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genScanFields name info dataRepr conInfos | not (hasTagField dataRepr) = return () @@ -903,6 +912,7 @@ genScanFieldTests lastIdx ((con,conRepr,conFields,scanCount),idx) <+> stat where stat = text ("return " ++ show (1 {-tag-} + scanCount) ++ ";") +-} genDupDropX :: Bool -> Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genDupDropX isDup name info dataRepr conInfos @@ -916,7 +926,13 @@ genDupDropX isDup name info dataRepr conInfos dupDropTests | dataRepr == DataEnum = ret | dataRepr == DataIso = [genDupDropIso isDup (head conInfos)] ++ ret - | dataRepr <= DataStruct = map (genDupDropTests isDup dataRepr (length conInfos)) (zip conInfos [1..]) ++ ret + -- | dataRepr == DataStructAsMaybe = [genDupDropMaybe isDup conInfos] ++ ret + | dataRepr <= DataStruct = genDupDropMatch (map (genDupDropTests isDup dataRepr) conInfos) ++ ret + {- + case (dataInfoDef info) of + DataDefValue _ scancount -> genDupDropValue isDup dataRepr scancount ++ ret + _ -> failure "Backend.C.genDupDropX: invalid value data definition?" + -} | otherwise = if (isDup) then [text "return" <+> (if dataReprMayHaveSingletons dataRepr then text "kk_datatype_dup" <.> arguments [text "_x"] @@ -931,10 +947,50 @@ genDupDropIso :: Bool -> (ConInfo,ConRepr,[(Name,Type)],Int) -> Doc genDupDropIso isDup (con,conRepr,[(name,tp)],scanCount) = hcat $ map (<.>semi) (genDupDropCall isDup tp (text "_x." <.> ppName name)) genDupDropIso _ _ - = failure $ "Backend.C.genDupDropIso: ivalid arguments" + = failure $ "Backend.C.genDupDropIso: invalid arguments" -genDupDropTests :: Bool -> DataRepr -> Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc -genDupDropTests isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) +-- coninfos are sorted with singletons first +genDupDropMaybe :: Bool -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Doc +genDupDropMaybe isDup [(conNothing,_,_,_),(conJust,_,[(fname,ftp)],_)] + = text "if" <+> parens (text "!" <.> conTestName conNothing <.> arguments [text "_x"]) <+> + (block $ vcat (genDupDropCall isDup ftp (text "_x._cons." <.> ppDefName (conInfoName conJust) <.> dot <.> ppName fname)) <.> semi) + +{- +genDupDropValue :: Bool -> DataRepr -> Int -> [Doc] +genDupDropValue isDup dataRepr 0 = [] +-- genDupDropValue isDup DataStructAsMaybe 1 -- todo: maybe specialize? +genDupDropValue isDup dataRepr scanCount + = [text "kk_box_t* _fields = (kk_box_t*)" <.> text (if hasTagField dataRepr then "&_x._cons._fields" else "&_x") <.> semi] + ++ + [text "kk_box_" <.> text (if isDup then "dup" else "drop") <.> arguments [text "_fields[" <.> pretty (i-1) <.> text "]"] <.> semi + | i <- [1..scanCount]] +-} + +block1 [stat] = text "{" <+> stat <+> text "}" +block1 stats = block (vcat stats) + +genDupDropMatch :: [(Doc,[Doc])] -> [Doc] +genDupDropMatch branches0 + = let branches = filter (not . null . snd) branches0 + complete = (length branches == length branches0) + genBranch iff (test,stats) + = text iff <+> parens test <+> block1 stats + in case branches of + [] -> [] + [(_,stats)] | (null stats || complete) + -> stats + (b:bs) -> [genBranch "if" b] ++ + [genBranch "else if" b | b <- if complete then init bs else bs] ++ + (if complete then [text "else" <+> block1 (snd (last bs))] else []) + +genDupDropTests :: Bool -> DataRepr -> (ConInfo,ConRepr,[(Name,Type)],Int) -> (Doc,[Doc]) +genDupDropTests isDup dataRepr (con,conRepr,conFields,scanCount) + = let dupdropFields = genDupDropFields isDup dataRepr con conFields + in (conTestName con <.> arguments [text "_x"], dupdropFields) + + +genDupDropTestsX :: Bool -> DataRepr -> Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc +genDupDropTestsX isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) = let stats = genDupDropFields isDup dataRepr con conFields in if (lastIdx == idx) then (if null stats @@ -971,25 +1027,41 @@ genDupDropCall :: Bool -> Type -> Doc -> [Doc] genDupDropCall isDup tp arg = if (isDup) then genDupDropCallX "dup" tp (arguments [arg]) else genDupDropCallX "drop" tp (arguments [arg]) + +-- The following functions are generated during "drop specialization" and "reuse specialization", +-- and only generated for heap allocated constructors so we can always use the `datatype_ptr` calls at runtime. genIsUniqueCall :: Type -> Doc -> [Doc] -genIsUniqueCall tp arg = case genDupDropCallX "is_unique" tp (arguments [arg]) of +genIsUniqueCall tp arg = {- case genDupDropCallX "is_unique" tp (arguments [arg]) of [call] -> [text "kk_likely" <.> parens call] cs -> cs + -} + [text "kk_likely" <.> parens (text "kk_datatype_ptr_is_unique" <.> arguments [arg])] + genFreeCall :: Type -> Doc -> [Doc] -genFreeCall tp arg = genDupDropCallX "free" tp (arguments [arg]) +genFreeCall tp arg = -- genDupDropCallX "free" tp (arguments [arg]) + [text "kk_datatype_ptr_free" <.> arguments [arg]] genDecRefCall :: Type -> Doc -> [Doc] -genDecRefCall tp arg = genDupDropCallX "decref" tp (arguments [arg]) +genDecRefCall tp arg = -- genDupDropCallX "decref" tp (arguments [arg]) + [text "kk_datatype_ptr_decref" <.> arguments [arg]] genDropReuseCall :: Type -> [Doc] -> [Doc] -genDropReuseCall tp args = genDupDropCallX "dropn_reuse" tp (arguments args) +genDropReuseCall tp args = -- genDupDropCallX "dropn_reuse" tp (arguments args) + [text "kk_datatype_ptr_dropn_reuse" <.> arguments args] genReuseCall :: Type -> Doc -> [Doc] -genReuseCall tp arg = genDupDropCallX "reuse" tp (arguments [arg]) +genReuseCall tp arg = -- genDupDropCallX "reuse" tp (arguments [arg]) + [text "kk_datatype_ptr_reuse" <.> arguments [arg]] genDropNCall :: Type -> [Doc] -> [Doc] -genDropNCall tp args = genDupDropCallX "dropn" tp (arguments args) +genDropNCall tp args = -- genDupDropCallX "dropn" tp (arguments args) + [text "kk_datatype_ptr_dropn" <.> arguments args] + +genHoleCall :: Type -> Doc +genHoleCall tp = -- ppType tp <.> text "_hole()") + text "kk_datatype_null()" + conBaseCastNameInfo :: ConInfo -> Doc conBaseCastNameInfo con = conBaseCastName (conInfoName con) @@ -1449,11 +1521,12 @@ genPatternTest doTest gfree (exprDoc,pattern) -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon -> do local <- newVarName "unbox" - let assign = ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi - unbox = genBoxCall "unbox" False {-True-} targ (ppDefName local) - next = genNextPatterns (\self fld -> self) {-(ppDefName local)-} unbox targ [pattern] - -- assign = ppType targ <+> ppDefName local <+> text "=" <+> unbox <.> semi - return [([],[assign],next)] + let assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] + unbox = genBoxCall "unbox" False targ (ppDefName local) + -- assign = [] + -- unbox = genBoxCall "unbox" True {- borrowing -} targ exprDoc + next = genNextPatterns (\self fld -> self) unbox targ [pattern] + return [([],assign,next)] PatVar tname pattern -> do let after = if (patternVarFree pattern && not (tnamesMember tname gfree)) then [] else [ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi] @@ -1766,7 +1839,7 @@ genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConF -- special: cfield-hole genAppNormal (Var unbox _) [App (Var cfieldHole _) []] | getName cfieldHole == nameCFieldHole && getName unbox == nameUnbox - = return ([],ppType (resultType (typeOf unbox)) <.> text "_hole()") + = return ([], genHoleCall (resultType (typeOf unbox))) -- ppType (resultType (typeOf unbox)) <.> text "_hole()") -- special: cfield-of genAppNormal (Var cfieldOf _) [App (Var box _) [App (Var dup _) [Var con _]], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf && getName dup == nameDup @@ -1995,7 +2068,7 @@ genExprExternal tname formats [argDoc] | getName tname == nameReuse -- special case: cfield hole genExprExternal tname formats [] | getName tname == nameCFieldHole - = return ([],ppType (resultType (typeOf tname)) <.> text "_hole()") + = return ([], genHoleCall (resultType (typeOf tname))) -- ppType (resultType (typeOf tname)) <.> text "_hole()") {- -- special case: cfield set From 365a3200b959266c5d5ae7a8438463733b1b59f7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 9 Dec 2022 16:22:38 -0800 Subject: [PATCH 101/233] clean up kklib.h --- kklib/include/kklib.h | 92 +++++++++------------------------- kklib/include/kklib/box.h | 16 +++--- kklib/include/kklib/os.h | 2 +- kklib/include/kklib/platform.h | 79 +++++++++++++++-------------- kklib/include/kklib/string.h | 2 +- kklib/src/os.c | 13 ++++- lib/std/core/hnd-inline.c | 2 +- lib/std/os/env.kk | 22 ++++++-- 8 files changed, 104 insertions(+), 124 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 19e559a6c..3774b2da5 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -157,6 +157,7 @@ static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_ #define _kk_unmake_value(x) ((x)&~KK_TAG_VALUE) #define _kk_unmake_ptr(x) ((x)&~KK_TAG_PTR) +#define kk_value_null (~KK_IB(0)) // must be a value // Polymorphic operations work on boxed values. (We use a struct for extra checks to prevent accidental conversion) // The least significant bit is clear for `kk_block_t*` pointers, while it is set for values. @@ -474,8 +475,8 @@ static inline kk_decl_pure bool kk_yielding_final(const kk_context_t* ctx) { // Get a thread local marker unique number >= 1. static inline int32_t kk_marker_unique(kk_context_t* ctx) { - int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; - if (m == INT32_MAX) ctx->marker_unique = 1; // controlled reset + int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; + if (m == INT32_MAX) { ctx->marker_unique = 1; } // controlled reset return m; } @@ -831,45 +832,12 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { /*-------------------------------------------------------------------------------------- - Datatype and Constructor macros - We use: - - basetype For a pointer to the base type of a heap allocated constructor. - Datatypes without singletons are always a basetype. - - datatype For a regular datatypes that can have singletons. + Base type and Constructor macros + - base_type For a pointer to the base type of a heap allocated constructor. - constructor For a pointer to a heap allocated constructor (whose first field is `_base` and points to the base type as a `basetype` --------------------------------------------------------------------------------------*/ -//#define kk_basetype_tag(v) (kk_block_tag(&((v)->_block))) -/* -#define kk_basetype_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) -#define kk_basetype_is_unique(v) (kk_block_is_unique(&((v)->_block))) -#define kk_basetype_as(tp,v) (kk_block_as(tp,&((v)->_block))) -#define kk_basetype_free(v,ctx) (kk_block_free(&((v)->_block),ctx)) -#define kk_basetype_decref(v,ctx) (kk_block_decref(&((v)->_block),ctx)) -#define kk_basetype_dup_as(tp,v) ((tp)kk_block_dup(&((v)->_block))) -#define kk_basetype_drop(v,ctx) (kk_block_dropi(&((v)->_block),ctx)) -#define kk_basetype_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_block),n,ctx)) -#define kk_basetype_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) -#define kk_basetype_reuse(v) (&((v)->_block)) -#define kk_basetype_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_block),x)) -#define kk_basetype_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) -#define kk_basetype_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) -#define kk_basetype_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) - -#define kk_constructor_tag(v) (kk_basetype_tag(&((v)->_base))) -#define kk_constructor_is_unique(v) (kk_basetype_is_unique(&((v)->_base))) -#define kk_constructor_free(v,ctx) (kk_basetype_free(&((v)->_base),ctx)) -#define kk_constructor_dup_as(tp,v) (kk_basetype_dup_as(tp, &((v)->_base))) -#define kk_constructor_drop(v,ctx) (kk_basetype_drop(&((v)->_base),ctx)) -#define kk_constructor_dropn_reuse(v,n,ctx) (kk_basetype_dropn_reuse(&((v)->_base),n,ctx)) -#define kk_constructor_field_idx_set(v,x) (kk_basetype_field_idx_set(&((v)->_base),x)) - -#define kk_value_dup(v) (v) -#define kk_value_drop(v,ctx) (void) -#define kk_value_drop_reuse(v,ctx) (kk_reuse_null) -*/ - #define kk_base_type_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) #define kk_base_type_is_unique(v) (kk_block_is_unique(&((v)->_block))) #define kk_base_type_as(tp,v) (kk_block_as(tp,&((v)->_block))) @@ -881,29 +849,28 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define kk_base_type_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) #define kk_base_type_reuse(v) (&((v)->_block)) #define kk_base_type_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_block),x)) + #define kk_base_type_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) #define kk_base_type_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) #define kk_base_type_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) - -#define kk_constructor_tag(v) (kk_block_tag(&((v)->_base._block))) -#define kk_constructor_is_unique(v) (kk_block_is_unique(&((v)->_base._block))) -#define kk_constructor_free(v,ctx) (kk_block_free(&((v)->_base._block),ctx)) -#define kk_constructor_dup_as(tp,v) (kk_block_dup_as(tp, &((v)->_base._block))) -#define kk_constructor_drop(v,ctx) (kk_block_drop(&((v)->_base._block),ctx)) -#define kk_constructor_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_base._block).,n,ctx)) -#define kk_constructor_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_base._block),x)) - #define kk_base_type_unbox_as_assert(tp,b,tag,ctx) (kk_block_as(tp,kk_block_unbox(b,tag,ctx))) #define kk_base_type_unbox_as(tp,b,ctx) ((tp)kk_base_type_as(tp,kk_ptr_unbox(b,ctx),ctx)) #define kk_base_type_box(b,ctx) (kk_block_box(&(b)->_block,ctx)) -#define kk_constructor_unbox_as(tp,b,tag,ctx) (kk_base_type_unbox_as_assert(tp,b,tag,ctx)) -#define kk_constructor_box(b,ctx) (kk_base_type_box(&(b)->_base),ctx) +#define kk_constructor_is_unique(v) (kk_base_type_is_unique(&((v)->_base))) +#define kk_constructor_free(v,ctx) (kk_base_type_free(&((v)->_base),ctx)) +#define kk_constructor_dup_as(tp,v) (kk_base_type_dup_as(tp, &((v)->_base))) +#define kk_constructor_drop(v,ctx) (kk_base_type_drop(&((v)->_base),ctx)) +#define kk_constructor_dropn_reuse(v,n,ctx) (kk_base_type_dropn_reuse(&((v)->_base),n,ctx)) +#define kk_constructor_field_idx_set(v,x) (kk_base_type_field_idx_set(&((v)->_base),x)) +#define kk_constructor_unbox_as(tp,b,tag,ctx) (kk_base_type_unbox_as_assert(tp,b,tag,ctx)) +#define kk_constructor_box(b,ctx) (kk_base_type_box(&(b)->_base),ctx) /*---------------------------------------------------------------------- - + Low-level encoding of small integers (`kk_intf_t`) and pointers + into a boxed integer `kk_intb_t`. ----------------------------------------------------------------------*/ #if !defined(KK_BOX_PTR_SHIFT) #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) @@ -959,10 +926,10 @@ static inline kk_intf_t kk_intf_decode(kk_intb_t b, int extra_shift) { - - /*---------------------------------------------------------------------- Datatypes + We use the `_ptr` suffix if it is guaranteed that the datatype + is a pointer and not a value (singleton). ----------------------------------------------------------------------*/ // create a singleton @@ -971,6 +938,7 @@ static inline kk_decl_const kk_datatype_t kk_datatype_from_tag(kk_tag_t t) { return d; } +// create a pointer into the heap static inline kk_decl_const kk_datatype_t kk_datatype_from_ptr(kk_ptr_t p, kk_context_t* ctx) { kk_datatype_t d = { kk_ptr_encode(p, ctx) }; return d; @@ -1123,10 +1091,10 @@ static inline void kk_datatype_ptr_decref(kk_datatype_t d, kk_context_t* ctx) { #define kk_datatype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_datatype_as_ptr(v,ctx),tag)) -#define kk_datatype_null_init { (kk_intb_t)KK_TAG_VALUE } +#define kk_datatype_null_init kk_value_null static inline kk_datatype_t kk_datatype_null(void) { - kk_datatype_t d = kk_datatype_null_init; + kk_datatype_t d = { kk_datatype_null_init }; return d; } @@ -1172,18 +1140,6 @@ static inline kk_datatype_t kk_datatype_ptr_unbox_assert(kk_box_t b, kk_tag_t t, return d; } -/* -#define kk_define_static_datatype(decl,kk_struct_tp,name,tag) \ - static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,tag) } }; \ - decl kk_struct_tp* name = &_static_##name - - // ignore otag as it is initialized dynamically -#define kk_define_static_open_datatype(decl,kk_struct_tp,name,otag) \ - static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_OPEN) }, &kk__static_string_empty._base }; \ - decl kk_struct_tp* name = &_static_##name -*/ - - /*---------------------------------------------------------------------- Reference counting of pattern matches @@ -1236,7 +1192,7 @@ typedef enum kk_unit_e { /*---------------------------------------------------------------------- - TLD operations + Thread local context operations ----------------------------------------------------------------------*/ // Get a thread local unique number. @@ -1259,7 +1215,7 @@ static inline void kk_unsupported_external(const char* msg) { /*-------------------------------------------------------------------------------------- - Value tags + Value tags (used for tags in structs) --------------------------------------------------------------------------------------*/ // Tag for value types is always an integer @@ -1362,7 +1318,7 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { #else // for a compressed heap, allocate static functions once in the heap on demand; these are never deallocated #define kk_define_static_function(name,cfun,ctx) \ - static kk_function_t name = kk_datatype_null_init; \ + static kk_function_t name = { kk_datatype_null_init }; \ if (kk_datatype_is_null(name)) { \ struct kk_function_s* _fun = kk_block_alloc_as(struct kk_function_s, 1, KK_TAG_FUNCTION, ctx); \ _fun->fun = kk_kkfun_ptr_box(&cfun, ctx); \ diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index c1fe36a8a..945f01478 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -92,16 +92,14 @@ static inline bool kk_box_eq(kk_box_t b1, kk_box_t b2) { } // null initializer -#define kk_box_null_init (~KK_IP(0)) +#define kk_box_null_init kk_value_null -// We cannot store NULL as a pointer (`kk_ptr_t`); use `box_null` instead +// We cannot store NULL as a pointer (`kk_ptr_t`); use `kk_box_null()` instead static inline kk_box_t kk_box_null(void) { kk_box_t b = { kk_box_null_init }; return b; } - - static inline bool kk_box_is_null(kk_box_t b) { return (b.box == kk_box_null_init); } @@ -389,8 +387,6 @@ typedef struct kk_cfunptr_s { kk_cfun_ptr_t cfunptr; } *kk_cfunptr_t; -// kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx); - // Koka function pointers // Best is if we can assume these are always aligned but that is difficult to ensure with various compilers. @@ -399,9 +395,9 @@ typedef struct kk_cfunptr_s { static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { // never drop; only used from function call kk_unused(ctx); intptr_t f = (intptr_t)fun; -#if KK_COMPRESS + #if KK_COMPRESS f = f - (intptr_t)&kk_main_start; -#endif + #endif kk_assert(kk_shrp(f, KK_INTPTR_BITS - 1) == 0); // assume top bit of function pointer addresses is clear kk_assert(f >= KK_INTF_BOX_MIN && f <= KK_INTF_BOX_MAX); kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value @@ -414,9 +410,9 @@ static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { static inline kk_cfun_ptr_t kk_kkfun_ptr_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); intptr_t f = kk_intf_decode(b.box, 0); -#if KK_COMPRESS + #if KK_COMPRESS f = f + (intptr_t)&kk_main_start; -#endif + #endif return (kk_cfun_ptr_t)f; } diff --git a/kklib/include/kklib/os.h b/kklib/include/kklib/os.h index e949d37af..92fb9c473 100644 --- a/kklib/include/kklib/os.h +++ b/kklib/include/kklib/os.h @@ -41,7 +41,7 @@ kk_decl_export kk_string_t kk_os_name(kk_context_t* ctx); kk_decl_export kk_string_t kk_cpu_arch(kk_context_t* ctx); kk_decl_export int kk_cpu_count(kk_context_t* ctx); kk_decl_export bool kk_cpu_is_little_endian(kk_context_t* ctx); - +kk_decl_export int kk_cpu_address_bits(kk_context_t* ctx); kk_decl_export bool kk_os_set_stack_size(kk_ssize_t stack_size); diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 5389dfef8..a7ea334a4 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -29,35 +29,52 @@ --------------------------------------------------------------------------------------*/ /*-------------------------------------------------------------------------------------- - Integer sizes and portability: + Integer sizes and portability + Here are some architectures with the bit size of various integers, where - - `uintptr_t` for addresses (where `sizeof(uintptr_t) == sizeof(void*)`), + - `intptr_t` for addresses (where `sizeof(intptr_t) == sizeof(void*)`), - `size_t` for object sizes, - `kk_intx_t` for the natural largest register size (for general arithmetic), - - `kk_intf_t` for the natural largest register size where |kk_intf_t| <= |uintptr_t|. - (this is used to store integer values in heap fields that are the size of a `uintptr_t`. - here we want to limit the `kk_intf_t` to be at most the size of `uintptr_t` (for - example on x32) but also not too large (for example, on arm CHERI we would still - use 64-bit arithmetic)). - + We always have: - - `|uintptr_t| >= |size_t| >= |kk_intf_t| >= |int|`. - - `|kk_intx_t| >= |kk_intf_t| >= |int|`. + - `|intptr_t| >= |size_t| >= |int|`. + - `|kk_intx_t| >= |int|`. - system uintptr_t size_t int long intx intf notes - ------------------ ----------- -------- ----- ------ ------ ------ ----------- - x86, arm32 32 32 32 32 32 32 - x64, arm64, etc. 64 64 32 64 64 64 - x64 windows 64 64 32 32 64 64 size_t > long - x32 linux 32 32 32 32 64 32 intx > size_t - arm CHERI 128 64 32 64 64 64 uintptr_t > size_t - riscV 128-bit 128 128 32 64 128 128 - x86 16-bit small 16 16 16 32 16 16 long > size_t - x86 16-bit large 32 16 16 32 16 16 uintptr_t/long > size_t - x86 16-bit huge 32 32 16 32 16 16 intx < size_t - - We use a signed `size_t` as `kk_ssize_t` (see comments below) and define - `kk_intf_t` is the `min(kk_intx_t,size_t)`. + system intptr_t size_t int long intx notes + ------------------ ----------- -------- ----- ------ ------ ----------- + x86, arm32 32 32 32 32 32 + x64, arm64, etc. 64 64 32 64 64 + x64 windows 64 64 32 32 64 size_t > long + x32 linux 32 32 32 32 64 intx_t > size_t + arm CHERI 128 64 32 64 64 intptr_t > size_t + riscV 128-bit 128 128 32 64 128 + x86 16-bit small 16 16 16 32 16 long > size_t + x86 16-bit large 32 16 16 32 16 intptr_t/long > size_t + x86 16-bit huge 32 32 16 32 16 size_t > intx_t + + We use a signed `size_t` as `kk_ssize_t` (see comments below) + + We also have: + - `kk_intb_t` (boxed integer) as the integer size that can hold a boxed value + - `kk_intf_t` (field integer) as the largest integer such that `|kk_intf_t| <= min(|kk_intb_t|,|kk_intx_t|)`. + + Usually `kk_intb_t` is equal to `kk_intptr_t` but it can smaller if heap + compression is used. This is controlled by the `KK_INTB_SIZE` define. + + system intptr_t size_t intx intb intf notes + ----------------------------- --------- -------- ------ ------ ------ ----------- + x64, arm64, 64 64 64 64 64 + x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 2^32 * 4 + + arm CHERI 128 64 64 128 64 |intb| > |intf| + arm CHERI compressed 64-bit 128 64 64 64 64 store addresses only in a box + arm CHERI compressed 32-bit 128 64 64 32 32 compress address as well + + riscV 128-bit 128 128 128 128 128 + riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 * 4 + riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 2^32 * 4 + x32 linux 32 32 64 32 32 |intx| > |intb| + --------------------------------------------------------------------------------------*/ /*-------------------------------------------------------------------------------------- @@ -320,7 +337,7 @@ static inline size_t kk_to_size_t(kk_ssize_t sz) { // We define `kk_intx_t` as an integer with the natural (fast) machine register size. -// We define it such that `sizeof(kk_intx_t)` is, with `m = max(sizeof(sizeof(long),sizeof(size_t))` +// We define it such that `sizeof(kk_intx_t)` is, with `m = max(sizeof(long),sizeof(size_t))` // (m==8 || x32) ? 8 : ((m == 4 && sizeof(int) > 2) ? 4 : sizeof(int)) // (We cannot use just `long` as it is sometimes too short (as on Windows 64-bit or x32 where a `long` is 32 bits). #if (LONG_MAX == INT64_MAX) || (SIZE_MAX == UINT64_MAX) || (defined(__x86_64__) && SIZE_MAX == UINT32_MAX) /* x32 */ @@ -368,18 +385,6 @@ typedef unsigned kk_uintx_t; #define KK_INTX_BITS (8*KK_INTX_SIZE) - -// We have |kk_intf_t| <= |kk_box_t| <= |intptr_t|. -// These are generally all the same size, on x64 they will all be 64-bit. -// But not always: -// - |kk_intf_t| can be smaller than |kk_box_t| if pointers are larger than natural ints (say x86 huge, or CHERI) -// - |kk_box_t| can be smaller than |intptr_t| if pointers are compressed. -// For example using a compressed heap with 32-bit pointers on a 64-bit system, or -// 64-bit addresses on a 128-bit CHERI system. -// -// The `kk_intf_t` represents the largest integer size that fits into `kk_box_t` (minus 1 bit) -// but which is not larger than the natural register size for integers. - // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) #define KK_INTB_SIZE KK_INTPTR_SIZE diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index d2659d989..651b64553 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -125,7 +125,7 @@ static inline kk_string_t kk_string_empty() { #define kk_declare_string_literal(decl,name,len,chars) \ static kk_ssize_t _static_len_##name = len; \ static const char* _static_##name = chars; \ - decl kk_string_t name = { kk_datatype_null_init }; + decl kk_string_t name = { { kk_datatype_null_init } }; #define kk_init_string_literal(name,ctx) \ if (kk_datatype_is_null(name.bytes)) { name = kk_string_alloc_from_utf8n(_static_len_##name, _static_##name, ctx); } diff --git a/kklib/src/os.c b/kklib/src/os.c index e3305feb8..54a8b86c2 100644 --- a/kklib/src/os.c +++ b/kklib/src/os.c @@ -1245,4 +1245,15 @@ bool kk_cpu_is_little_endian(kk_context_t* ctx) { #else return false; #endif -} \ No newline at end of file +} + +int kk_cpu_address_bits(kk_context_t* ctx) { + size_t bsize; + #if __CHERI__ + bsize = sizeof(vaddr_t); + #else + bsize = sizeof(void*); + #endif + return (int)(CHAR_BIT * bsize); +} + diff --git a/lib/std/core/hnd-inline.c b/lib/std/core/hnd-inline.c index 0081830e2..b1b510406 100644 --- a/lib/std/core/hnd-inline.c +++ b/lib/std/core/hnd-inline.c @@ -45,7 +45,7 @@ static kk_std_core_hnd__ev* kk_evv_as_vec(kk_evv_t evv, kk_ssize_t* len, kk_std_ } kk_std_core_hnd__ev kk_ev_none(kk_context_t* ctx) { - static kk_std_core_hnd__ev ev_none_singleton = kk_datatype_null_init; + static kk_std_core_hnd__ev ev_none_singleton = { kk_datatype_null_init }; if (kk_datatype_is_null(ev_none_singleton)) { ev_none_singleton = kk_std_core_hnd__new_Ev( kk_reuse_null, diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 79fcb4626..952f30d74 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -100,23 +100,35 @@ pub extern get-cpu-is-little-endian() : ndet bool // Return the processor architecture natural machine word size in bits. // -// Note: Usually this equals the `get-cpu-object-bits` and `get-cpu-address-bits` on modern cpu's +// Note: Usually this equals the `get-cpu-object-bits` and `get-cpu-pointer-bits` on modern cpu's // but they can differ on segmented architectures. // For example, on the old x86 FAR-NEAR model, the addresses are 32-bit but the maximum object size is 16-bit. // Or on the more recent-[x32 ABI](https://en.wikipedia.org/wiki/X32_ABI) // the addresses and objects are 32-bits but the architecture has 64-bit registers. pub extern get-cpu-arch-bits() : ndet int - c inline "kk_integer_from_size_t(CHAR_BIT*(sizeof(size_t) > sizeof(long) ? sizeof(size_t) : sizeof(long)),kk_context())" + c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(kk_intx_t),kk_context())" js inline "32" // Return the processor maximum object size in bits (`8*sizeof(size_t)`). This is usually // equal to the `get-cpu-arch-bits` but may be different on segmented architectures. -pub extern get-cpu-object-bits() : ndet int +pub extern get-cpu-size-bits() : ndet int c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(size_t),kk_context())" js inline "32" -// Return the processor maximum address size in bits (`8*sizeof(void*)`). This is usually -// equal to the `get-cpu-arch-bits` but may be different on segmented architectures. +// Return the processor maximum address size in bits (`8*sizeof(vaddr_t)`). This is usually +// equal to the `get-cpu-pointer-bits` but may be different on capability architectures like ARM CHERI. pub extern get-cpu-address-bits() : ndet int + c inline "kk_integer_from_int(kk_cpu_address_bits(kk_context()),kk_context())" + js inline "32" + +// Return the processor maximum pointer size in bits (`8*sizeof(void*)`). This is usually +// equal to the `get-cpu-address-bits` but may be larger on capability architectures like ARM CHERI. +pub extern get-cpu-pointer-bits() : ndet int c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(void*),kk_context())" js inline "32" + +// Return the size of boxed values in the heap (`8*sizeof(kk_box_t)`). This is usually +// equal to `8*sizeof(void*)` but can be less if compressed pointers are used. +pub extern get-cpu-boxed-bits() : ndet int + c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(kk_intb_t),kk_context())" + js inline "32" From 50f84464e7ef3554be5a92b7d6f1e31bdc3e9fd3 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 09:42:20 -0800 Subject: [PATCH 102/233] further encapsulate tag bits --- kklib/include/kklib.h | 49 +++--- kklib/include/kklib/box.h | 10 +- kklib/include/kklib/integer.h | 304 +++++++++------------------------ kklib/include/kklib/os.h | 2 +- kklib/include/kklib/platform.h | 20 ++- kklib/src/box.c | 33 ++-- kklib/src/integer.c | 2 +- kklib/src/os.c | 3 +- 8 files changed, 137 insertions(+), 286 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 3774b2da5..633570e27 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -149,18 +149,14 @@ static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_ #define KK_TAG_PTR (0) #define KK_TAG_VALUE (1) -#define kk_is_value(x) (((x)&KK_TAG_MASK)!=KK_TAG_PTR) -#define kk_is_ptr(x) (((x)&KK_TAG_MASK)==KK_TAG_PTR) - -#define _kk_make_value(x) ((x)|KK_TAG_VALUE) -#define _kk_make_ptr(x) ((x)|KK_TAG_PTR) -#define _kk_unmake_value(x) ((x)&~KK_TAG_VALUE) -#define _kk_unmake_ptr(x) ((x)&~KK_TAG_PTR) - -#define kk_value_null (~KK_IB(0)) // must be a value +static inline bool kk_is_ptr(kk_intb_t i) { + return ((i & KK_TAG_MASK) == KK_TAG_PTR); +} +static inline bool kk_is_value(kk_intb_t i) { + return !kk_is_ptr(i); +} // Polymorphic operations work on boxed values. (We use a struct for extra checks to prevent accidental conversion) -// The least significant bit is clear for `kk_block_t*` pointers, while it is set for values. // See `box.h` for definitions. typedef struct kk_box_s { kk_intb_t box; @@ -876,51 +872,54 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) #endif +#define kk_value_null ((~KK_IB(0)&~KK_TAG_MASK)|KK_TAG_VALUE) // must be some value + + static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); + intptr_t i = (intptr_t)p; #if KK_COMPRESS - intptr_t i = (intptr_t)p - ctx->heap_base; + i = i - ctx->heap_base; #if KK_BOX_PTR_SHIFT > 0 i = kk_sarp(i, KK_BOX_PTR_SHIFT); - #endif - kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); - return _kk_make_ptr((kk_intb_t)i); + #endif #else kk_unused(ctx); - return _kk_make_ptr((kk_intb_t)p); #endif + kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); + return ((kk_intb_t)i | KK_TAG_PTR); } static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { kk_assert_internal(kk_is_ptr(b)); + intptr_t i = (b & ~KK_TAG_PTR); #if KK_COMPRESS - intptr_t i = _kk_unmake_ptr(b); #if KK_BOX_PTR_SHIFT > 0 + kk_assert_internal((i & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); i = kk_shlp(i, KK_BOX_PTR_SHIFT); #endif - i = i + ctx->heap_base; - return (kk_ptr_t)i; + i = i + ctx->heap_base; #else kk_unused(ctx); - return (kk_ptr_t)_kk_unmake_ptr(b); #endif + return (kk_ptr_t)i; } -#define KK_INTF_BOX_BITS (KK_INTF_BITS-KK_TAG_BITS) -#define KK_INTF_BOX_MAX ((kk_intf_t)KK_INTF_MAX >> (KK_INTF_BITS - KK_INTF_BOX_BITS)) -#define KK_INTF_BOX_MIN (- KK_INTF_BOX_MAX - 1) - +#define KK_INTF_BOX_MAX ((kk_intf_t)KK_INTF_MAX >> KK_TAG_BITS) +#define KK_INTF_BOX_MIN (-KK_INTF_BOX_MAX - 1) +#define KK_UINTF_BOX_MAX ((kk_uintf_t)KK_UINTF_MAX >> KK_TAG_BITS) static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { kk_assert_internal(extra_shift >= 0); kk_assert_internal(i >= (KK_INTF_BOX_MIN / (KK_IF(1)<= 0); kk_assert_internal(kk_is_value(b) || b == kk_get_context()->kk_box_any.dbox); - kk_intb_t i = kk_sarb(_kk_unmake_value(b),KK_TAG_BITS + extra_shift); + kk_intb_t i = kk_sarb( b & ~KK_TAG_VALUE, KK_TAG_BITS + extra_shift); + kk_assert_internal(i >= KK_INTF_MIN && i <= KK_INTF_MAX); return (kk_intf_t)i; } diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 945f01478..d36f4da23 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -150,12 +150,14 @@ static inline kk_box_t kk_intf_box(kk_intf_t i) { static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { kk_assert_internal(kk_box_is_value(b) || kk_box_is_any(b)); - return (kk_uintf_t)kk_intf_unbox(b); + kk_intf_t i = kk_intf_unbox(b); + return (kk_uintf_t)kk_shrf(kk_shlf(i, KK_TAG_BITS), KK_TAG_BITS); } static inline kk_box_t kk_uintf_box(kk_uintf_t u) { - kk_assert_internal(u <= KK_INTF_BOX_MAX); - return kk_intf_box((kk_intf_t)u); + kk_assert_internal(u <= KK_UINTF_BOX_MAX); + kk_intf_t i = kk_sarf(kk_shlf((kk_intf_t)u, KK_TAG_BITS), KK_TAG_BITS); + return kk_intf_box(i); } @@ -398,7 +400,7 @@ static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { #if KK_COMPRESS f = f - (intptr_t)&kk_main_start; #endif - kk_assert(kk_shrp(f, KK_INTPTR_BITS - 1) == 0); // assume top bit of function pointer addresses is clear + kk_assert(kk_shrp(f, KK_INTPTR_BITS - KK_TAG_BITS) == 0); // assume top bits of function pointer addresses are clear kk_assert(f >= KK_INTF_BOX_MIN && f <= KK_INTF_BOX_MAX); kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value return b; diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 53d10fa9d..159f0f1f4 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -154,7 +154,6 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. #define KK_INT_USE_OVF 1 // use limited tag bits and architecture overflow detection (only with gcc/clang) #define KK_INT_USE_TAGOVF 2 // use tag bits (upfront check) and architecture overflow detection (only with gcc/clang) #define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits -#define KK_INT_USE_RENO 4 // use range extended overflow arithmetic #ifndef KK_INT_ARITHMETIC #if (KK_INTF_SIZE <= 4) && defined(__GNUC__) @@ -164,10 +163,6 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. #endif #endif -#ifndef KK_INT_TAG -#define KK_INT_TAG (1) -#endif - #if KK_INT_ARITHMETIC == KK_INT_USE_OVF || KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF typedef kk_intf_t kk_smallint_t; #define KK_SMALLINT_BITS (KK_INTF_BITS) @@ -197,45 +192,28 @@ typedef int8_t kk_smallint_t; #define KK_SMALLINT_MAX (KK_INTF_MAX >> (KK_INTF_BITS - KK_SMALLINT_BITS + KK_INT_TAG_BITS)) #define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) -static inline kk_intf_t _kk_integer_value(kk_integer_t i) { - return (kk_intf_t)i.ibox; // potentially cast to smaller kk_intf_t (as on arm CHERI) -} - -#if KK_INT_ARITHMETIC != KK_INT_USE_RENO static inline bool kk_is_smallint(kk_integer_t i) { - #if KK_INT_TAG==1 - return ((_kk_integer_value(i)&1) != 0); - #else - return ((_kk_integer_value(i)&1) == 0); - #endif + return kk_is_value(i.ibox); } static inline bool kk_is_bigint(kk_integer_t i) { - return !kk_is_smallint(i); + return kk_is_ptr(i.ibox); } static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i, kk_context_t* ctx) { kk_assert_internal(kk_is_bigint(i)); - #if KK_INT_TAG==KK_TAG_VALUE - return kk_ptr_decode(i.ibox,ctx); - #else - return kk_ptr_decode(i.ibox^1, ctx); - #endif -} - -static inline kk_integer_t _kk_new_integer(kk_intf_t i) { - kk_integer_t z = { i }; - return z; + return kk_ptr_decode(i.ibox,ctx); } static inline kk_intf_t kk_smallint_from_integer(kk_integer_t i) { // use for known small ints kk_assert_internal(kk_is_smallint(i)); - return kk_sarf(_kk_integer_value(i),2); + return kk_intf_decode(i.ibox,1); } static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for known small int constants (at most 14 bits) kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return _kk_new_integer(kk_shlf(i,2)|KK_INT_TAG); + kk_integer_t z = { kk_intf_encode(i,1) }; + return z; } static inline bool kk_is_integer(kk_integer_t i) { @@ -245,74 +223,16 @@ static inline bool kk_is_integer(kk_integer_t i) { static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); - return (((_kk_integer_value(i)&_kk_integer_value(j))&1) == KK_INT_TAG); - //return ((_kk_integer_value(i)&1)==1 || (_kk_integer_value(j)&1)==1); -} - -#else // KK_INT_USE_RENO -#define KK_INT_MINPTR (KK_IF(1) << (KK_INTF_BITS - 2)) - -static inline bool kk_is_smallint(kk_integer_t i) { - //return (_kk_integer_value(i) < KK_INT_MINPTR); - //return (_kk_integer_value(i) <= KK_SMALLINT_MAX); - //kk_intf_t x = _kk_integer_value(i); - //return (x == (kk_smallint_t)x); - //return ((kk_uintf_t)((x>>32)+1) <= 1); - return ((_kk_integer_value(i)>>(KK_INTF_BITS-2)) <= 0); -} - -static inline bool kk_is_bigint(kk_integer_t i) { - return !kk_is_smallint(i); -} - -static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { - kk_assert_internal(kk_is_bigint(i)); - return (kk_ptr_t)(kk_shlp(i.ibox,2)); -} - -static inline kk_integer_t _kk_new_integer(kk_intf_t i) { - kk_integer_t z = { (uintptr_t)(i) }; - return z; -} - -static inline kk_intf_t kk_smallint_from_integer(kk_integer_t i) { // use for known small ints - kk_assert_internal(kk_is_smallint(i) && (_kk_integer_value(i) >= KK_SMALLINT_MIN)); - return _kk_integer_value(i); -} - -static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for known small int constants (at most 14 bits) - kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return _kk_new_integer(i); -} - -static inline kk_integer_t kk_integer_from_ptr(kk_block_t* p) { // use for known small int constants (at most 14 bits) - //kk_integer_t z = { kk_shrp((uintptr_t)p,2) | KK_INT_MINPTR }; - kk_integer_t z = { kk_bits_rotr((uintptr_t)p+1,2) }; // avoid large constants in code (use + instead of | for clang codegen) - return z; -} - -static inline bool kk_is_integer(kk_integer_t i) { - return ((kk_is_smallint(i) && kk_smallint_from_integer(i) >= KK_SMALLINT_MIN && kk_smallint_from_integer(i) <= KK_SMALLINT_MAX) - || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i)) == KK_TAG_BIGINT)); -} - -#define KK_SMALLINT_MAX1 (KK_SMALLINT_MAX+1) -static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { - kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); - // return (kk_is_smallint(i) && kk_is_smallint(j)); - kk_intf_t x = _kk_integer_value(i); - kk_intf_t y = _kk_integer_value(j); - //return (((((kk_uintf_t)x+KK_SMALLINT_MAX+1)|((kk_uintf_t)y+KK_SMALLINT_MAX+1)) & KK_INT_MINPTR) != 0); - return ((x>>(KK_INTF_BITS-3))+(y>>(KK_INTF_BITS-3)) <= 0); - //kk_intf_t z = x + y; - //return (z == (int32_t)z); + #if KK_TAG_VALUE == 1 + return kk_is_value(i.ibox & j.ibox); + #else + return (kk_is_smallint(i) && kk_is_smallint(j)); + #endif } -#endif - static inline bool kk_integer_small_eq(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); - return (_kk_integer_value(x) == _kk_integer_value(y)); + return (x.ibox == y.ibox); } #define kk_integer_zero (kk_integer_from_small(0)) @@ -320,17 +240,17 @@ static inline bool kk_integer_small_eq(kk_integer_t x, kk_integer_t y) { #define kk_integer_min_one (kk_integer_from_small(-1)) static inline bool kk_integer_is_zero_borrow(kk_integer_t x) { - if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_zero)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x,kk_integer_zero); return false; } static inline bool kk_integer_is_one_borrow(kk_integer_t x) { - if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_one)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x, kk_integer_one); return false; } static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { - if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_min_one)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x, kk_integer_min_one); return false; } @@ -338,44 +258,18 @@ static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { Generic operations on integers -----------------------------------------------------------------------------------*/ -#if KK_INT_ARITHMETIC != KK_INT_USE_RENO // Isomorphic with boxed values static inline kk_box_t kk_integer_box(kk_integer_t i, kk_context_t* ctx) { kk_unused(ctx); - #if KK_INT_TAG == KK_TAG_VALUE kk_box_t b = { i.ibox }; - #else - kk_box_t b = { i.ibox ^ 1 }; - #endif return b; } static inline kk_integer_t kk_integer_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); - #if KK_INT_TAG == KK_TAG_VALUE kk_integer_t i = { b.box }; - #else - kk_integer_t i = { b.box ^ 1 }; - #endif return i; } -#else -static inline kk_box_t kk_integer_box(kk_integer_t i, kk_context_t* ctx) { - return (kk_is_smallint(i) ? kk_intf_box(kk_smallint_from_integer(i)) : kk_ptr_box(_kk_integer_ptr(i),ctx)); -} -static inline kk_integer_t kk_integer_unbox(kk_box_t b, kk_context_t* ctx) { - return (kk_box_is_value(b) ? kk_integer_from_small(kk_intf_unbox(b)) : kk_integer_from_ptr(kk_ptr_unbox(b,ctx))); -} -#endif -#ifdef KK_INT_NOREFCOUNT -static inline kk_integer_t kk_integer_dup(kk_integer_t i) { - return i; -} - -static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { - kk_unused(i); kk_unused(ctx); -} -#else static inline kk_integer_t kk_integer_dup(kk_integer_t i, kk_context_t* ctx) { if kk_unlikely(kk_is_bigint(i)) { kk_block_dup(_kk_integer_ptr(i,ctx)); } return i; @@ -384,7 +278,7 @@ static inline kk_integer_t kk_integer_dup(kk_integer_t i, kk_context_t* ctx) { static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { if kk_unlikely(kk_is_bigint(i)) { kk_block_drop(_kk_integer_ptr(i,ctx), ctx); } } -#endif + kk_decl_export bool kk_integer_parse(const char* num, kk_integer_t* result, kk_context_t* ctx); kk_decl_export bool kk_integer_hex_parse(const char* s, kk_integer_t* res, kk_context_t* ctx); @@ -571,7 +465,18 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: we check before multiply for small integers and do not combine with the overflow check. -----------------------------------------------------------------------------------*/ -#if (KK_INT_ARITHMETIC == KK_INT_USE_OVF) +static kk_intf_t _kk_integer_value(kk_integer_t i) { + kk_assert_internal(kk_is_smallint(i)); + return (kk_intf_t)i.ibox; +} + +static kk_integer_t _kk_new_integer(kk_intf_t i) { + kk_integer_t z = { i }; + kk_assert_internal(kk_is_smallint(z)); + return z; +} + +#if (KK_INT_ARITHMETIC == KK_INT_USE_OVF) && (KK_TAG_VALUE==1) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; @@ -613,7 +518,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, return _kk_new_integer(z|1); } -#elif (KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF) // test for small ints upfront +#elif (KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF) && (KK_TAG_VALUE==1) // test for small ints upfront static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; @@ -655,48 +560,6 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, return _kk_new_integer(z | 1); } - -#elif (KK_INT_ARITHMETIC == KK_INT_USE_RENO) - -static inline bool kk_not_in_small_range( kk_intf_t i ) { - //return (i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return ((kk_smallint_t)i != i); -} - -static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_add_generic(x, y, ctx); - return _kk_new_integer(z); -} - -static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { - kk_intf_t z = _kk_integer_value(x) + i; - if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); - return _kk_new_integer(z); -} - -static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if 1 - kk_intf_t z = _kk_integer_value(x) - _kk_integer_value(y); - if kk_unlikely(!kk_is_smallint(y) || kk_not_in_small_range(z)) return kk_integer_sub_generic(x, y, ctx); - //if kk_unlikely(!kk_is_smallint(y)) return kk_integer_add_generic(x,y,ctx); - return _kk_new_integer(z); - #else - const kk_intf_t i = _kk_integer_value(x); - const kk_intf_t z = i + i - _kk_integer_value(y); - if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_sub_generic(x, y, ctx); - return _kk_new_integer(z - i); - #endif -} - -static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_assert_internal(kk_are_smallints(x, y)); - kk_intf_t z = _kk_integer_value(x) * _kk_integer_value(y); - // if kk_unlikely(!kk_are_smallints(x,y)) return kk_integer_mul_generic(x, y, ctx); - if kk_unlikely(kk_not_in_small_range(z)) return kk_integer_mul_generic(x, y, ctx); - return _kk_new_integer(z); -} - #elif (KK_INT_ARITHMETIC == KK_INT_USE_SOFA) // we can either mask on the left side or on the sign extended right side. @@ -705,7 +568,7 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, #define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif -#if KK_INT_TAG == 1 +#if (KK_TAG_VALUE == 1) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); @@ -753,7 +616,6 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con #else // KK_INT_TAG == 0 - static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); #ifndef KK_INT_SOFA_RIGHT_BIAS @@ -783,7 +645,6 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); } - static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) - (_kk_integer_value(y)^3) + 3; #ifndef KK_INT_SOFA_RIGHT_BIAS @@ -798,7 +659,7 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con return kk_integer_sub_generic(x, y, ctx); } -#endif +#endif // KK_TAG_VALUE == 1 or 0 static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); @@ -807,15 +668,16 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t z = i*j; if kk_likely(z == (kk_smallint_t)(z)) { kk_assert_internal((z&3) == 0); - return _kk_new_integer(z|KK_INT_TAG); + return _kk_new_integer(z|KK_TAG_VALUE); } return kk_integer_mul_generic(x, y, ctx); } #else -#error unknown arithmetic mode! +#error "Define fast arithmetic primitives for this platform" #endif + static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if kk_likely(kk_are_smallints(x, y)) return kk_integer_mul_small(x, y, ctx); return kk_integer_mul_generic(x, y, ctx); @@ -831,8 +693,8 @@ static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_cdiv_small(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); kk_assert_internal(!kk_integer_is_zero_borrow(y)); - kk_intf_t i = kk_sarf(_kk_integer_value(x), 1); - kk_intf_t j = kk_sarf(_kk_integer_value(y), 1); + kk_intf_t i = kk_smallint_from_integer(x); + kk_intf_t j = kk_smallint_from_integer(y); return kk_integer_from_small(i/j); } @@ -988,15 +850,7 @@ static inline kk_integer_t kk_integer_abs(kk_integer_t x, kk_context_t* ctx) { } static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if KK_INT_ARITHMETIC == KK_INT_USE_RENO - if (_kk_integer_value(x) == _kk_integer_value(y)) return 0; - if kk_likely(kk_is_smallint(x)) { - if (_kk_integer_value(x) > _kk_integer_value(y)) return 1; - if kk_likely(kk_is_smallint(y)) return -1; - } - #else if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); - #endif return kk_integer_cmp_generic_borrow(x, y, ctx); } @@ -1026,25 +880,19 @@ static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* c } static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - #if 0 // KK_INT_ARITHMETIC == KK_INT_USE_RENO - if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) >= _kk_integer_value(y)); - #else if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) >= _kk_integer_value(y)); - #endif return (kk_integer_cmp_generic_borrow(x, y, ctx) >= 0); } static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; if kk_likely(kk_is_smallint(x)) return false; - //if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic_borrow(x, y, ctx) == 0); } static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { if (_kk_integer_value(x) == _kk_integer_value(y)) return true; if kk_likely(kk_is_smallint(x)) return false; - // if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small return (kk_integer_cmp_generic(x, y, ctx) == 0); } @@ -1109,11 +957,11 @@ static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_con static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT32_MAX) + #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); -#else + #else return (int32_t)i; -#endif + #endif } else { return kk_integer_clamp32_generic(x,ctx); @@ -1123,11 +971,11 @@ static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ctx) { // used for cfc field of evidence if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT32_MAX) + #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); -#else + #else return (int32_t)i; -#endif + #endif } else { return kk_integer_clamp32_generic(kk_integer_dup(x,ctx), ctx); @@ -1137,11 +985,11 @@ static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ct static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT64_MAX) + #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); -#else + #else return (int64_t)i; -#endif + #endif } else { return kk_integer_clamp64_generic(x, ctx); @@ -1151,11 +999,11 @@ static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { static inline int64_t kk_integer_clamp64_borrow(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT64_MAX) + #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); -#else + #else return (int64_t)i; -#endif + #endif } else { return kk_integer_clamp64_generic(kk_integer_dup(x,ctx), ctx); @@ -1180,63 +1028,63 @@ static inline int16_t kk_integer_clamp_int16(kk_integer_t x, kk_context_t* ctx) static inline size_t kk_integer_clamp_size_t(kk_integer_t x, kk_context_t* ctx) { if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > SIZE_MAX) + #if (KK_SMALLINT_MAX > SIZE_MAX) return (i < 0 ? 0 : (i > SIZE_MAX ? SIZE_MAX : (size_t)i)); -#else + #else return (i < 0 ? 0 : (size_t)i); -#endif + #endif } return kk_integer_clamp_size_t_generic(x,ctx); } static inline kk_ssize_t kk_integer_clamp_ssize_t(kk_integer_t x, kk_context_t* ctx) { -#if KK_SSIZE_MAX == INT32_MAX + #if KK_SSIZE_MAX == INT32_MAX return kk_integer_clamp32(x,ctx); -#elif KK_SSIZE_MAX == INT64_MAX + #elif KK_SSIZE_MAX == INT64_MAX return kk_integer_clamp64(x,ctx); -#else -#error "define integer_clamp_ssize_t on this platform" -#endif + #else + #error "define integer_clamp_ssize_t on this platform" + #endif } static inline kk_ssize_t kk_integer_clamp_ssize_t_borrow(kk_integer_t x, kk_context_t* ctx) { // used for array indexing -#if KK_SSIZE_MAX == INT32_MAX + #if KK_SSIZE_MAX == INT32_MAX return kk_integer_clamp32_borrow(x, ctx); -#elif KK_SSIZE_MAX == INT64_MAX + #elif KK_SSIZE_MAX == INT64_MAX return kk_integer_clamp64_borrow(x, ctx); -#else -#error "define integer_clamp_ssize_t_borrow on this platform" -#endif + #else + #error "define integer_clamp_ssize_t_borrow on this platform" + #endif } static inline intptr_t kk_integer_clamp_intptr_t(kk_integer_t x, kk_context_t* ctx) { -#if INTPTR_MAX == INT32_MAX + #if INTPTR_MAX == INT32_MAX return kk_integer_clamp32(x,ctx); -#elif INTPTR_MAX == INT64_MAX + #elif INTPTR_MAX == INT64_MAX return kk_integer_clamp64(x,ctx); -#else -#error "define integer_clamp_intptr_t on this platform" -#endif + #else + #error "define integer_clamp_intptr_t on this platform" + #endif } static inline kk_intx_t kk_integer_clamp(kk_integer_t x, kk_context_t* ctx) { -#if KK_INTX_MAX == INT32_MAX + #if KK_INTX_MAX == INT32_MAX return kk_integer_clamp32(x, ctx); -#elif KK_INTX_MAX == INT64_MAX + #elif KK_INTX_MAX == INT64_MAX return kk_integer_clamp64(x, ctx); -#else -#error "define integer_clamp on this platform" -#endif + #else + #error "define integer_clamp on this platform" + #endif } static inline kk_intx_t kk_integer_clamp_borrow(kk_integer_t x, kk_context_t* ctx) { -#if KK_INTX_MAX == INT32_MAX + #if KK_INTX_MAX == INT32_MAX return kk_integer_clamp32_borrow(x, ctx); -#elif KK_INTX_MAX == INT64_MAX + #elif KK_INTX_MAX == INT64_MAX return kk_integer_clamp64_borrow(x, ctx); -#else -#error "define integer_clamp_borrow on this platform" -#endif + #else + #error "define integer_clamp_borrow on this platform" + #endif } static inline double kk_integer_as_double(kk_integer_t x, kk_context_t* ctx) { diff --git a/kklib/include/kklib/os.h b/kklib/include/kklib/os.h index 92fb9c473..083c05099 100644 --- a/kklib/include/kklib/os.h +++ b/kklib/include/kklib/os.h @@ -26,7 +26,7 @@ kk_decl_export int kk_os_read_line(kk_string_t* result, kk_context_t* ctx); kk_decl_export int kk_os_read_text_file(kk_string_t path, kk_string_t* result, kk_context_t* ctx); kk_decl_export int kk_os_write_text_file(kk_string_t path, kk_string_t content, kk_context_t* ctx); -kk_decl_export int kk_os_ensure_dir(kk_string_t dir, int mode, kk_context_t* ctx); +kk_decl_export int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx); kk_decl_export int kk_os_copy_file(kk_string_t from, kk_string_t to, bool preserve_mtime, kk_context_t* ctx); kk_decl_export bool kk_os_is_directory(kk_string_t path, kk_context_t* ctx); kk_decl_export bool kk_os_is_file(kk_string_t path, kk_context_t* ctx); diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index a7ea334a4..d02eb9216 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -398,6 +398,7 @@ typedef intptr_t kk_intb_t; typedef uintptr_t kk_uintb_t; #define KK_INTB_MAX INTPTR_MAX #define KK_INTB_MIN INTPTR_MIN +#define KK_UINTB_MAX UINTPTR_MAX #define KK_IB(i) KK_IP(i) #define KK_UB(i) KK_UP(i) #define PRIdIB "zd" @@ -407,6 +408,7 @@ typedef int64_t kk_intb_t; typedef uint64_t kk_uintb_t; #define KK_INTB_MAX INT64_MAX #define KK_INTB_MIN INT64_MIN +#define KK_UINTB_MAX UINT64_MAX #define KK_IB(i) KK_I64(i) #define KK_UB(i) KK_U64(i) #define PRIdIB PRIdI64 @@ -416,6 +418,7 @@ typedef int32_t kk_intb_t; typedef uint32_t kk_uintb_t; #define KK_INTB_MAX INT32_MAX #define KK_INTB_MIN INT32_MIN +#define KK_UINTB_MAX UINT32_MAX #define KK_IB(i) KK_I32(i) #define KK_UB(i) KK_U32(i) #define PRIdIB PRIdI32 @@ -428,13 +431,15 @@ typedef uint32_t kk_uintb_t; #endif // Largest natural integer that fits into a boxed value -#if (KK_INTB_SIZE > KK_SIZE_SIZE) // ensure it fits the natural register size -typedef kk_ssize_t kk_intf_t; -typedef size_t kk_uintf_t; -#define KK_IF(i) KK_IZ(i) -#define KK_INTF_SIZE KK_SSIZE_SIZE -#define KK_INTF_MAX KK_SSIZE_MAX -#define KK_INTF_MIN KK_SSIZE_MIN +#if (KK_INTB_SIZE > KK_INTX_SIZE) // ensure it fits the natural register size +typedef kk_intx_t kk_intf_t; +typedef kk_uintx_t kk_uintf_t; +#define KK_IF(i) KK_IX(i) +#define KK_INTF_SIZE KK_INTX_SIZE +#define KK_INTF_MAX KK_INTX_MAX +#define KK_INTF_MIN KK_INTX_MIN +#define KK_UINTF_MAX KK_UINTX_MAX +#define PRIdIF PRIdIX #else typedef kk_intb_t kk_intf_t; typedef kk_uintb_t kk_uintf_t; @@ -442,6 +447,7 @@ typedef kk_uintb_t kk_uintf_t; #define KK_INTF_SIZE KK_INTB_SIZE #define KK_INTF_MAX KK_INTB_MAX #define KK_INTF_MIN KK_INTB_MIN +#define KK_UINTF_MAX KK_UINTB_MAX #define PRIdIF PRIdIB #endif #define KK_INTF_BITS (8*KK_INTF_SIZE) diff --git a/kklib/src/box.c b/kklib/src/box.c index 51b8d8785..fdda7a2eb 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -275,11 +275,10 @@ static kk_box_t kk_double_box_heap(double d, kk_context_t* ctx) { #if (KK_BOX_DOUBLE64 == 2) // heap allocate when negative kk_box_t kk_double_box(double d, kk_context_t* ctx) { kk_unused(ctx); - uint64_t i = kk_bits_from_double(d); + uint64_t u = kk_bits_from_double(d); //if (isnan(d)) { kk_debugger_break(ctx); } - if ((int64_t)i >= 0) { // positive? - kk_box_t b = { ((uintptr_t)i<<1)|1 }; - return b; + if (u <= KK_UINTF_BOX_MAX) { // fits in a boxed value? (i.e. is the double positive) + return kk_uintf_box(u); } else { // heap allocate @@ -292,8 +291,7 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { double d; if (kk_box_is_value(b)) { // positive double - uint64_t u = kk_shrp(b.box, 1); - d = kk_bits_to_double(u); + d = kk_bits_to_double(kk_uintf_unbox(b)); } else { // heap allocated @@ -324,18 +322,17 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { return kk_double_box_heap(d, ctx); } kk_assert_internal(exp <= 0x3FF); - kk_box_t b = { (intptr_t)_kk_make_value(u | (exp<<1)) }; - return b; + kk_assert_internal((kk_shr64(u,1) & 0x3FF) == 0); + return kk_uintf_box( kk_shr64(u,1) | exp ); } double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); if (kk_box_is_value(b)) { // expand 10-bit exponent to 11-bits again - uint64_t u = b.box; - uint64_t exp = u & 0x7FF; - u -= exp; // clear lower 11 bits - exp >>= 1; + uint64_t u = kk_uintf_unbox(b); + uint64_t exp = u & 0x3FF; + u -= exp; // clear lower 10 bits if (exp == 0) { // ok } @@ -346,7 +343,7 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { exp += 0x200; } kk_assert_internal(exp <= 0x7FF); - u = kk_bits_rotr64(u | exp, 12); + u = kk_bits_rotr64( kk_shl64(u,1) | exp, 12); double d = kk_bits_to_double(u); return d; } @@ -385,10 +382,9 @@ static kk_box_t kk_float_box_heap(float f, kk_context_t* ctx) { kk_box_t kk_float_box(float f, kk_context_t* ctx) { kk_unused(ctx); - uint32_t i = kk_bits_from_float(f); - if ((int32_t)i >= 0) { // positive? - kk_box_t b = { ((intptr_t)i<<1)|1 }; - return b; + uint32_t u = kk_bits_from_float(f); + if (u <= KK_UINTF_BOX_MAX) { // fits in a boxed value? (i.e. is the double positive) + return kk_uintf_box(u); } else { // heap allocate @@ -401,8 +397,7 @@ float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { float f; if (kk_box_is_value(b)) { // positive float - uint32_t u = (uint32_t)kk_shrp(b.box, 1); - f = kk_bits_to_float(u); + f = kk_bits_to_float(kk_uintf_unbox(b)); } else { // heap allocated diff --git a/kklib/src/integer.c b/kklib/src/integer.c index f5de9bc47..a6f22c4f5 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -189,7 +189,7 @@ static kk_ptr_t bigint_ptr_(kk_bigint_t* x) { static kk_integer_t bigint_as_integer_(kk_bigint_t* x, kk_context_t* ctx) { kk_integer_t i = { kk_ptr_encode(bigint_ptr_(x), ctx) }; -#if KK_INT_TAG!=KK_TAG_VALUE +#if KK_TAG_VALUE!=KK_TAG_VALUE i.ibox = i.ibox ^ 1; #endif return i; diff --git a/kklib/src/os.c b/kklib/src/os.c index 54a8b86c2..c141f1756 100644 --- a/kklib/src/os.c +++ b/kklib/src/os.c @@ -280,7 +280,7 @@ static bool kk_is_dir(const char* cpath) { } #endif -kk_decl_export int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx) +int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx) { int err = 0; if (mode < 0) { @@ -1248,6 +1248,7 @@ bool kk_cpu_is_little_endian(kk_context_t* ctx) { } int kk_cpu_address_bits(kk_context_t* ctx) { + kk_unused(ctx); size_t bsize; #if __CHERI__ bsize = sizeof(vaddr_t); From 4296489dd93b94a1f4572208056826dc38ed170f Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 10:19:41 -0800 Subject: [PATCH 103/233] make refcount signed again --- kklib/include/kklib.h | 21 +++++++----- kklib/src/refcount.c | 75 ++++++++++++++++++++++--------------------- 2 files changed, 52 insertions(+), 44 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 633570e27..32d78b2cd 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -97,21 +97,26 @@ static inline bool kk_tag_is_raw(kk_tag_t tag) { // The reference count is 0 for a unique reference (for a faster free test in drop). -// Reference counts larger than 0x8000000 (i.e. < 0) use atomic increment/decrement (for thread shared objects). +// Negative reference counts use atomic increment/decrement (for thread shared objects). // (Reference counts are always 32-bit (even on 64-bit) platforms but get "sticky" if -// they get too large and in such case we never free the object, see `refcount.c`) -typedef uint32_t kk_refcount_t; +// they overflow into the negative range and in such case we never free the object, see `refcount.c`) +typedef int32_t kk_refcount_t; // Are there (possibly) references from other threads? (includes static variables) static inline bool kk_refcount_is_thread_shared(kk_refcount_t rc) { - return ((int32_t)rc < 0); + return (rc < 0); } // Is the reference unique, or are there (possibly) references from other threads? (includes static variables) static inline bool kk_refcount_is_unique_or_thread_shared(kk_refcount_t rc) { - return ((int32_t)rc <= 0); + return (rc <= 0); } +// Increment a positive reference count. To avoid UB use unsigned addition. +static inline kk_refcount_t kk_refcount_inc(kk_refcount_t rc) { + kk_assert_internal(rc >= 0); + return (kk_refcount_t)((uint32_t)rc + 1); +} // Every heap block starts with a 64-bit header with a reference count, tag, and scan fields count. @@ -124,8 +129,8 @@ typedef struct kk_header_s { } kk_header_t; #define KK_SCAN_FSIZE_MAX (0xFF) -#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with refcount of 0 -#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(KK_U32(0x80000000)) } // start with a stuck refcount (RC_STUCK) +#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with refcount of 0 +#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(INT32_MIN) } // start with a stuck refcount (RC_STUCK) static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_t tag) { kk_assert_internal(scan_fsize >= 0 && scan_fsize <= KK_SCAN_FSIZE_MAX); @@ -680,7 +685,7 @@ static inline kk_block_t* kk_block_dup(kk_block_t* b) { return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? } else { - kk_block_refcount_set(b, rc+1); + kk_block_refcount_set(b, kk_refcount_inc(rc)); return b; } } diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index f9f4d41b0..2980220fa 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -41,14 +41,15 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { Checked reference counts. positive: - 0 : unique reference - 0x00000001 - 0x7FFFFFFF : reference count (in a single thread) (~2.1e9 counts) + 0 : unique reference + 1 to INT32_MAX : reference count (in a single thread) (~2.1e9 counts) + negative: - 0x80000000 : sticky: single-threaded stricky reference count (RC_STUCK) - 0x80000001 - 0x90000000 : sticky: neither increment, nor decrement - 0x90000001 - 0xA0000000 : sticky: still decrements (dup) but no more increments (drop) - 0xA0000001 - 0xFFFFFFFF : thread-shared reference counts with atomic increment/decrement. (~1.6e9 counts) - 0xFFFFFFFF : RC_SHARED_UNIQUE (-1) + INT32_MIN : sticky: single-threaded stricky reference count (RC_STUCK) + INT32_MIN+1 to INT32_MIN+0x10000000 : sticky: neither increment, nor decrement + INT32_MIN+0x10000001 to INT32_MIN+0x20000000 : sticky: still decrements (dup) but no more increments (drop) + INT32_MIN+0x20000001 to -2 : thread-shared reference counts with atomic increment/decrement. (~1.6e9 counts) + -1 : thread-shared reference count that is unique now (RC_SHARED_UNIQUE) 0 <= refcount <= MAX_INT32 @@ -59,11 +60,18 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { MAX_INT32 < refcount <= MAX_UINT32 Thread-shared and sticky reference counts. These use atomic increment/decrement operations. - MAX_INT32 + 1 == RC_STUCK + MIN_INT32 == RC_STUCK This is used for single threaded refcounts that overflow. (This is sticky and the object will never be freed) The thread-shared refcounts will never get there. - MAX_INT32 < refcount <= RC_STICKY_DROP + RC_STICKY_DROP < refcount <= -1 (= RC_UNIQUE_SHARED) + A thread-shared reference count. + The reference count grows down, e.g. if there are N references to a + thread-shared object, then the reference count is -N. + It means that to dup a thread-shared reference will _decrement_ the count, + and to drop will _increment_ the count. + + MIN_INT32 < refcount <= RC_STICKY_DROP The sticky range. An object in this range will never be freed anymore. Since we first read the reference count non-atomically we need a range for stickiness. Once `refcount <= RC_STICKY_DROP` it will never drop anymore @@ -71,13 +79,6 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { We assume that the relaxed reads of the reference counts catch up to the atomic value within the sticky range (which has a range of ~0.5e9 counts). - RC_STICKY_DROP < refcount <= MAX_UINT32 (= RC_UNIQUE_SHARED) - A thread-shared reference count. - The reference count grows down, e.g. if there are N references to a thread-shared object - the reference count is (RC_UNIQUE_SHARED - N + 1), (i.e. in a signed representation it is -N). - It means that to dup a thread-shared reference will _decrement_ the count, - and to drop will _increment_ the count. - Atomic memory ordering: - Increments can be relaxed as there is no dependency on order, the owner could access fields just as well before or after incrementing. @@ -89,10 +90,10 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { - see also: https://devblogs.microsoft.com/oldnewthing/20210409-00/?p=105065 --------------------------------------------------------------------------------------*/ -#define RC_STUCK KK_U32(0x80000000) -#define RC_STICKY KK_U32(0x90000000) -#define RC_STICKY_DROP KK_U32(0xA0000000) -#define RC_SHARED_UNIQUE KK_U32(0xFFFFFFFF) +#define RC_STUCK (INT32_MIN) +#define RC_STICKY (RC_STUCK + 0x10000000) +#define RC_STICKY_DROP (RC_STUCK + 0x20000000) +#define RC_SHARED_UNIQUE (-1) static inline kk_refcount_t kk_atomic_dup(kk_block_t* b) { return kk_atomic_dec_relaxed(&b->header.refcount); @@ -106,10 +107,12 @@ static inline kk_refcount_t kk_atomic_acquire(kk_block_t* b) { static void kk_block_make_shared(kk_block_t* b) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already - rc = RC_SHARED_UNIQUE - rc; // signed: -1 - rc - if (rc <= RC_STICKY_DROP) rc = RC_STICKY; // for high reference counts - kk_block_refcount_set(b, rc); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); // not thread shared already + if (!kk_refcount_is_thread_shared(rc)) { + rc = -rc; // cannot overflow as rc is positive + if (rc <= RC_STICKY_DROP) { rc = RC_STICKY; } // for high reference counts default to sticky + kk_block_refcount_set(b, rc); + } } // Check if a reference dup needs an atomic operation @@ -117,9 +120,9 @@ kk_decl_noinline kk_block_t* kk_block_check_dup(kk_block_t* b, kk_refcount_t rc0 kk_assert_internal(b!=NULL); kk_assert_internal(kk_refcount_is_thread_shared(rc0)); // includes KK_STUCK if kk_likely(rc0 > RC_STICKY) { - kk_atomic_dup(b); + kk_atomic_dup(b); // decrement } - // else sticky: no longer increment (or decrement) + // else sticky: no longer dup (= decrement) return b; } @@ -137,7 +140,7 @@ kk_decl_noinline void kk_block_check_drop(kk_block_t* b, kk_refcount_t rc0, kk_c // sticky: do not drop further } else { - const kk_refcount_t rc = kk_atomic_drop(b); + const kk_refcount_t rc = kk_atomic_drop(b); // increment if (rc == RC_SHARED_UNIQUE) { // this was the last reference? kk_atomic_acquire(b); // prevent reordering of reads/writes before this point kk_block_refcount_set(b,0); // no longer shared @@ -181,7 +184,7 @@ kk_decl_noinline void kk_block_check_decref(kk_block_t* b, kk_refcount_t rc0, kk // sticky: do not decrement further } else { - const kk_refcount_t rc = kk_atomic_drop(b); + const kk_refcount_t rc = kk_atomic_drop(b); // decrement if (rc == RC_SHARED_UNIQUE) { // last referenc? kk_block_refcount_set(b,0); // no longer shared kk_free(b,ctx); // no more references, free it. @@ -580,36 +583,36 @@ static kk_decl_noinline void kk_block_mark_shared_recx_large(kk_block_t* b, kk_c // (This is unlike freeing where we can use it as we are freeing it anyways) // So, we steal 8 bits of an unshared reference count. If the reference count // is too large we just set it to RC_STUCK when it gets marked. -#define KK_RC_MARK_MAX KK_U32(0x7FFFFF) +#define KK_RC_MARK_MAX KK_I32(0x007FFFFF) static void kk_block_mark_idx_prepare(kk_block_t* b) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); if (rc > KK_RC_MARK_MAX) { rc = KK_RC_MARK_MAX; } // if rc is too large, cap it - rc = (rc << 8); // make room for 8-bit mark index - kk_assert_internal(rc < RC_STUCK); + rc = kk_shl32(rc,8); // make room for 8-bit mark index + kk_assert_internal(rc>=0); kk_assert_internal((rc & 0xFF) == 0); kk_block_refcount_set(b, rc); } static void kk_block_mark_idx_done(kk_block_t* b) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); rc = kk_shr32(rc, 8); - if (rc >= KK_RC_MARK_MAX) { rc = RC_STUCK; } // make it sticky if it was too large to contain an index + if (rc >= KK_RC_MARK_MAX) { rc = INT32_MAX; } // ensure it will become stuck if it was too large to contain an index kk_block_refcount_set(b, rc); } static void kk_block_mark_idx_set(kk_block_t* b, uint8_t i) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); rc = ((rc & ~0xFF) | i); kk_block_refcount_set(b, rc); } static uint8_t kk_block_mark_idx(kk_block_t* b) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); return (uint8_t)rc; } From acc2c2c30a5a4313d22730f998a1096b9f23fb20 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 10:30:45 -0800 Subject: [PATCH 104/233] use faster enum encoding --- kklib/include/kklib.h | 2 +- kklib/include/kklib/box.h | 7 +++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 32d78b2cd..ace8a02a9 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 98 // modify on changes to trigger recompilation +#define KKLIB_BUILD 97 // modify on changes to trigger recompilation #define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index d36f4da23..05699352c 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -298,11 +298,14 @@ static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag, kk_context static inline kk_uintf_t kk_enum_unbox(kk_box_t b) { - return kk_uintf_unbox(b); + kk_intf_t i = kk_intf_unbox(b); + kk_assert_internal(i >= 0); + return (kk_uintf_t)i; } static inline kk_box_t kk_enum_box(kk_uintf_t u) { - return kk_uintf_box(u); + kk_assert_internal(u <= KK_INTF_BOX_MAX); + return kk_intf_box((kk_intf_t)u); } static inline kk_box_t kk_box_box(kk_box_t b, kk_context_t* ctx) { From 7a869469657f891fe5fe6c9765f925a7e6a07d5d Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 11:00:25 -0800 Subject: [PATCH 105/233] clean up kklib.h --- kklib/include/kklib.h | 265 +++++++++++++++++++++--------------------- kklib/src/init.c | 4 + kklib/src/refcount.c | 6 +- 3 files changed, 143 insertions(+), 132 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index ace8a02a9..6c61a99e4 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -95,7 +95,6 @@ static inline bool kk_tag_is_raw(kk_tag_t tag) { Headers --------------------------------------------------------------------------------------*/ - // The reference count is 0 for a unique reference (for a faster free test in drop). // Negative reference counts use atomic increment/decrement (for thread shared objects). // (Reference counts are always 32-bit (even on 64-bit) platforms but get "sticky" if @@ -112,7 +111,7 @@ static inline bool kk_refcount_is_unique_or_thread_shared(kk_refcount_t rc) { return (rc <= 0); } -// Increment a positive reference count. To avoid UB use unsigned addition. +// Increment a positive reference count. To avoid UB on overflow, use unsigned addition. static inline kk_refcount_t kk_refcount_inc(kk_refcount_t rc) { kk_assert_internal(rc >= 0); return (kk_refcount_t)((uint32_t)rc + 1); @@ -129,7 +128,7 @@ typedef struct kk_header_s { } kk_header_t; #define KK_SCAN_FSIZE_MAX (0xFF) -#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with refcount of 0 +#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with unique refcount #define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(INT32_MIN) } // start with a stuck refcount (RC_STUCK) static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_t tag) { @@ -147,21 +146,8 @@ static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_ Box, Integer, Datatype --------------------------------------------------------------------------------------*/ -// We generally tag boxed values; the least-significant bit is clear for heap pointers (`kk_ptr_t == kk_block_t*`), -// while the bit is set for values. -#define KK_TAG_BITS (1) -#define KK_TAG_MASK ((1<yielding == KK_YIELD_FINAL); } - // Get a thread local marker unique number >= 1. static inline int32_t kk_marker_unique(kk_context_t* ctx) { int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; @@ -481,10 +461,14 @@ static inline int32_t kk_marker_unique(kk_context_t* ctx) { return m; } +kk_decl_export kk_context_t* kk_main_start(int argc, char** argv); +kk_decl_export void kk_main_end(kk_context_t* ctx); -kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ); -kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ); -kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); +kk_decl_export void kk_debugger_break(kk_context_t* ctx); +kk_decl_export void kk_fatal_error(int err, const char* msg, ...); +kk_decl_export void kk_warning_message(const char* msg, ...); +kk_decl_export void kk_info_message(const char* msg, ...); +kk_decl_export void kk_unsupported_external(const char* msg); kk_decl_export kk_datatype_ptr_t kk_evv_empty_singleton(kk_context_t* ctx); @@ -832,6 +816,15 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { } +/*-------------------------------------------------------------------------------------- + Thread-shared marking (see `refcount.c`) +--------------------------------------------------------------------------------------*/ + +kk_decl_export void kk_block_mark_shared(kk_block_t* b, kk_context_t* ctx); +kk_decl_export void kk_box_mark_shared(kk_box_t b, kk_context_t* ctx); +kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); + + /*-------------------------------------------------------------------------------------- Base type and Constructor macros - base_type For a pointer to the base type of a heap allocated constructor. @@ -873,13 +866,31 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { Low-level encoding of small integers (`kk_intf_t`) and pointers into a boxed integer `kk_intb_t`. ----------------------------------------------------------------------*/ -#if !defined(KK_BOX_PTR_SHIFT) -#define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) -#endif +// We generally tag boxed values; the least-significant bit is clear for heap pointers (`kk_ptr_t == kk_block_t*`), +// while the bit is set for values. +#define KK_TAG_BITS (1) +#define KK_TAG_MASK ((1<> KK_TAG_BITS) #define KK_INTF_BOX_MIN (-KK_INTF_BOX_MAX - 1) #define KK_UINTF_BOX_MAX ((kk_uintf_t)KK_UINTF_MAX >> KK_TAG_BITS) @@ -1183,8 +1196,6 @@ typedef enum kk_unit_e { kk_Unit = 0 } kk_unit_t; - - #include "kklib/bits.h" #include "kklib/box.h" #include "kklib/integer.h" @@ -1206,104 +1217,23 @@ static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { return u; } -kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); -kk_decl_export void kk_fatal_error(int err, const char* msg, ...); -kk_decl_export void kk_warning_message(const char* msg, ...); -kk_decl_export void kk_info_message(const char* msg, ...); - -static inline void kk_unsupported_external(const char* msg) { - kk_fatal_error(ENOSYS, "unsupported external: %s", msg); -} - - +kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); /*-------------------------------------------------------------------------------------- - Value tags (used for tags in structs) ---------------------------------------------------------------------------------------*/ - -// Tag for value types is always an integer -typedef kk_integer_t kk_value_tag_t; - -#define kk_value_tag(tag) (kk_integer_from_small(tag)) - -static inline kk_decl_const bool kk_value_tag_eq(kk_value_tag_t x, kk_value_tag_t y) { - // note: x or y may be box_any so don't assert they are smallints - return (_kk_integer_value(x) == _kk_integer_value(y)); -} - -/*-------------------------------------------------------------------------------------- - Optimized support for maybe like datatypes. - We try to avoid allocating for maybe-like types. First we define maybe as a value - type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag - and payload. This does not help though if it becomes boxed, say, a list of maybe - values. In that case we can still avoid allocation through the special TAG_NOTHING - and TAG_JUST tags. If the Just value is neither of those, we just use it directly - without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) - are allocated, and sometimes value types like `int32` if these happen to be equal - to `kk_box_Nothing`. + kk_Unit --------------------------------------------------------------------------------------*/ -static inline kk_box_t kk_box_Nothing(void) { - return kk_datatype_box( kk_datatype_from_tag(KK_TAG_NOTHING) ); -} - -static inline bool kk_box_is_Nothing(kk_box_t b) { - return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); -} - -static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b,ctx), KK_TAG_JUST)); -} - -static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { - return (kk_box_is_Just(b,ctx) || kk_box_is_Nothing(b)); -} - -typedef struct kk_just_s { - struct kk_block_s _block; - kk_box_t value; -} kk_just_t; - -kk_decl_export kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ); - -static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { - if (kk_box_is_ptr(b)) { - kk_block_t* bl = kk_ptr_unbox(b,ctx); - if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { - return kk_unbox_Just_block(bl,ctx); - } - } - // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b - return b; -} -static inline kk_box_t kk_box_Just( kk_box_t b, kk_context_t* ctx ) { - if kk_likely(!kk_box_is_maybe(b,ctx)) { - return b; - } - else { - kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); - just->value = b; - return kk_ptr_box(&just->_block,ctx); - } +static inline kk_decl_const kk_box_t kk_unit_box(kk_unit_t u) { + return kk_intf_box((kk_intf_t)u); } -static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { - kk_assert_internal(!kk_box_is_maybe(b,kk_get_context())); - return kk_datatype_unbox(b); +static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { + kk_unused_internal(u); + kk_assert_internal(kk_intf_unbox(u) == (kk_intf_t)kk_Unit || kk_box_is_any(u)); + return kk_Unit; // (kk_unit_t)kk_enum_unbox(u); } -static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { - kk_unused(ctx); - kk_assert_internal(!kk_datatype_has_singleton_tag(d,KK_TAG_NOTHING)); - if (kk_datatype_is_ptr(d)) { - kk_block_t* b = kk_datatype_as_ptr(d,ctx); - if (kk_block_has_tag(b,KK_TAG_JUST)) { - return kk_block_field(b,0); - } - } - return kk_datatype_box(d); -} /*-------------------------------------------------------------------------------------- Functions @@ -1358,7 +1288,6 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) } - /*-------------------------------------------------------------------------------------- Vector --------------------------------------------------------------------------------------*/ @@ -1460,10 +1389,10 @@ static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t } - /*-------------------------------------------------------------------------------------- References --------------------------------------------------------------------------------------*/ + struct kk_ref_s { kk_block_t _block; _Atomic(kk_intb_t) value; @@ -1539,18 +1468,94 @@ static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx),ctx); } + /*-------------------------------------------------------------------------------------- - kk_Unit + Value tags (used for tags in structs) --------------------------------------------------------------------------------------*/ -static inline kk_decl_const kk_box_t kk_unit_box(kk_unit_t u) { - return kk_intf_box((kk_intf_t)u); +// Tag for value types is always an integer +typedef kk_integer_t kk_value_tag_t; + +#define kk_value_tag(tag) (kk_integer_from_small(tag)) + +static inline kk_decl_const bool kk_value_tag_eq(kk_value_tag_t x, kk_value_tag_t y) { + // note: x or y may be box_any so don't assert they are smallints + return (_kk_integer_value(x) == _kk_integer_value(y)); } -static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { - kk_unused_internal(u); - kk_assert_internal( kk_intf_unbox(u) == (kk_intf_t)kk_Unit || kk_box_is_any(u)); - return kk_Unit; // (kk_unit_t)kk_enum_unbox(u); + +/*-------------------------------------------------------------------------------------- + Optimized support for maybe like datatypes. + We try to avoid allocating for maybe-like types. First we define maybe as a value + type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag + and payload. This does not help though if it becomes boxed, say, a list of maybe + values. In that case we can still avoid allocation through the special TAG_NOTHING + and TAG_JUST tags. If the Just value is neither of those, we just use it directly + without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) + are allocated, and sometimes value types like `int32` if these happen to be equal + to `kk_box_Nothing`. +--------------------------------------------------------------------------------------*/ + +static inline kk_box_t kk_box_Nothing(void) { + return kk_datatype_box(kk_datatype_from_tag(KK_TAG_NOTHING)); +} + +static inline bool kk_box_is_Nothing(kk_box_t b) { + return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); +} + +static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b, ctx), KK_TAG_JUST)); +} + +static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_Just(b, ctx) || kk_box_is_Nothing(b)); +} + +typedef struct kk_just_s { + struct kk_block_s _block; + kk_box_t value; +} kk_just_t; + +kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_context_t* ctx); + +static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_ptr(b)) { + kk_block_t* bl = kk_ptr_unbox(b, ctx); + if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { + return kk_unbox_Just_block(bl, ctx); + } + } + // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b + return b; +} + +static inline kk_box_t kk_box_Just(kk_box_t b, kk_context_t* ctx) { + if kk_likely(!kk_box_is_maybe(b, ctx)) { + return b; + } + else { + kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); + just->value = b; + return kk_ptr_box(&just->_block, ctx); + } +} + +static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { + kk_assert_internal(!kk_box_is_maybe(b, kk_get_context())); + return kk_datatype_unbox(b); +} + +static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { + kk_unused(ctx); + kk_assert_internal(!kk_datatype_has_singleton_tag(d, KK_TAG_NOTHING)); + if (kk_datatype_is_ptr(d)) { + kk_block_t* b = kk_datatype_as_ptr(d, ctx); + if (kk_block_has_tag(b, KK_TAG_JUST)) { + return kk_block_field(b, 0); + } + } + return kk_datatype_box(d); } diff --git a/kklib/src/init.c b/kklib/src/init.c index a09636157..29ff65c6e 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -141,6 +141,10 @@ void kk_info_message(const char* fmt, ...) { va_end(args); } +void kk_unsupported_external(const char* msg) { + kk_fatal_error(ENOSYS, "unsupported external: %s", msg); +} + /*-------------------------------------------------------------------------------------------------- Process init/done --------------------------------------------------------------------------------------------------*/ diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 2980220fa..2b486a0f0 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -90,10 +90,12 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { - see also: https://devblogs.microsoft.com/oldnewthing/20210409-00/?p=105065 --------------------------------------------------------------------------------------*/ -#define RC_STUCK (INT32_MIN) +#define RC_STUCK INT32_MIN #define RC_STICKY (RC_STUCK + 0x10000000) #define RC_STICKY_DROP (RC_STUCK + 0x20000000) -#define RC_SHARED_UNIQUE (-1) +#define RC_SHARED_UNIQUE KK_I32(-1) +#define RC_UNIQUE KK_I32(0) + static inline kk_refcount_t kk_atomic_dup(kk_block_t* b) { return kk_atomic_dec_relaxed(&b->header.refcount); From b29da4ab18e83126059e1ea8b6baca57b8759243 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 15:45:11 -0800 Subject: [PATCH 106/233] better ctail_set_context_path as a typed function --- kklib/include/kklib.h | 13 ++++---- kklib/include/kklib/platform.h | 55 +++++++++++++++++----------------- src/Backend/C/FromCore.hs | 3 +- 3 files changed, 38 insertions(+), 33 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 6c61a99e4..f913b662c 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -10,7 +10,6 @@ ---------------------------------------------------------------------------*/ #define KKLIB_BUILD 97 // modify on changes to trigger recompilation -#define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -1570,10 +1569,14 @@ static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { // functional context composition by copying along the context path and attaching `child` at the hole. kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); -// use a macro as `x` can be a datatype or direct pointer; update the field_idx with the field -// index + 1 that is along the context path, and return `x` as is. -#define kk_ctail_set_context_path(as_tp,x,field_offset,ctx) \ - (kk_constructor_field_idx_set( as_tp(x,ctx), 1 + ((field_offset - sizeof(kk_header_t))/sizeof(kk_box_t)) ), x) +// update the field_idx with the field index + 1 that is along the context path, and return `d` as is. +static inline kk_datatype_t kk_ctail_set_context_path(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { + kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); + kk_assert_internal(kk_datatype_is_ptr(d)); + const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); + kk_block_field_idx_set( kk_datatype_as_ptr(d,ctx), 1 + field_index); + return d; +} #endif diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index d02eb9216..2fd445c63 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -14,7 +14,7 @@ Platform: we assume: - C99 as C compiler (syntax and library), with possible C11 extensions for threads and atomics. - Write code such that it can be compiled with a C++ compiler as well (used with msvc) - - Either a 32- or 64-bit platform (but others should be possible with few changes). + - Either a 32, 64, or 128-bit platform (but others should be possible with few changes). - The compiler can do a great job on small static inline definitions (and we avoid #define's to get better static type checks). - The compiler will inline small structs (like `struct kk_box_s{ uintptr_t u; }`) without @@ -28,6 +28,29 @@ Only use unsigned for bitfields or masks. --------------------------------------------------------------------------------------*/ +/*-------------------------------------------------------------------------------------- + Object size and signed/unsigned: + We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` (`PTRDIFF_MAX`) bytes + so we can always use the signed `kk_ssize_t` (instead of `size_t`) to specify sizes + and do indexing in arrays. This avoids: + - Signed/unsigned conversion (especially when mixing pointer arithmetic and lengths). + - Subtle loop bound errors (consider `for(unsigned u = 0; u < len()-1; u++)` if `len()` + happens to be `0` etc.). + - Performance degradation -- modern compilers can compile signed loop variables + better (as signed overflow is undefined). + - Wrong API usage (passing a negative value is easier to detect) + + A drawback is that this limits object sizes to half the address space-- for 64-bit + this is not a problem but string lengths for example on 32-bit are limited to be + "just" 2^31 bytes at most. Nevertheless, we feel this is an acceptible trade-off + (especially since the largest object is nowadays is already limited in practice + to `PTRDIFF_MAX` e.g. ). + + We also need some helpers to deal with API's (like `strlen`) that use `size_t` + results or arguments, where we clamp the values into the `kk_ssize_t` range + (but again, on modern systems no clamping will ever happen as these already limit the size of objects to PTRDIFF_MAX) +--------------------------------------------------------------------------------------*/ + /*-------------------------------------------------------------------------------------- Integer sizes and portability @@ -45,7 +68,7 @@ x86, arm32 32 32 32 32 32 x64, arm64, etc. 64 64 32 64 64 x64 windows 64 64 32 32 64 size_t > long - x32 linux 32 32 32 32 64 intx_t > size_t + x32 linux 32 32 32 32 64 intx_t > size_t,intptr_t arm CHERI 128 64 32 64 64 intptr_t > size_t riscV 128-bit 128 128 32 64 128 x86 16-bit small 16 16 16 32 16 long > size_t @@ -64,41 +87,19 @@ system intptr_t size_t intx intb intf notes ----------------------------- --------- -------- ------ ------ ------ ----------- x64, arm64, 64 64 64 64 64 - x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 2^32 * 4 + x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 2^32 (*4) arm CHERI 128 64 64 128 64 |intb| > |intf| arm CHERI compressed 64-bit 128 64 64 64 64 store addresses only in a box arm CHERI compressed 32-bit 128 64 64 32 32 compress address as well riscV 128-bit 128 128 128 128 128 - riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 * 4 - riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 2^32 * 4 + riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 (*4) + riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 2^32 (*4) x32 linux 32 32 64 32 32 |intx| > |intb| --------------------------------------------------------------------------------------*/ -/*-------------------------------------------------------------------------------------- - Object size and signed/unsigned: - We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` bytes - so we can always use the signed `kk_ssize_t` (instead of `size_t`) to specify sizes - and do indexing in arrays. This avoids: - - Signed/unsigned conversion (especially when mixing pointer arithmetic and lengths), - - Loop bound errors (consider `for(unsigned u = 0; u < len()-1; u++)` if `len()` - happens to be `0` etc.), - - Performance degradation -- modern compilers can compile signed loop variables - better (as signed overflow is undefined), - - Wrong API usage (passing a negative value is easier to detect) - - A drawback is that this limits object sizes to half the address space-- for 64-bit - this is not a problem but string lengths for example on 32-bit are limited to be - "just" 2^31 bytes at most. Nevertheless, we feel this is an acceptible trade-off - (especially since `malloc` nowadays is already limited to `PTRDIFF_MAX`). - - We also need some helpers to deal with API's (like `strlen`) that use `size_t` - results or arguments, where we clamp the values into the `kk_ssize_t` range - (but then, on modern systems no clamping will ever happen as these already limit - the size of objects to SIZE_MAX/2 internally) ---------------------------------------------------------------------------------------*/ #if defined(__clang_major__) && __clang_major__ < 9 #error koka requires at least clang version 9 (due to atomics support) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index f4687d25b..4e31796dc 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1923,7 +1923,8 @@ genFieldAddress conVar conName fieldName genCTailSetContextPath :: TName -> Name -> Name -> Doc genCTailSetContextPath conVar conName fieldName = text "kk_ctail_set_context_path" <.> - arguments [conAsNameX conName, ppName (getName conVar), + arguments [-- conAsNameX conName, + ppName (getName conVar), text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] genAppSpecial :: Expr -> [Expr] -> Asm (Maybe Doc) From fd33b5c7578a405456a82a8cdf4e020c9d9be6a5 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sat, 10 Dec 2022 16:19:38 -0800 Subject: [PATCH 107/233] move parts of kklib.h into separate header files --- kklib/include/kklib.h | 339 +++++------------------------------ kklib/include/kklib/maybe.h | 86 +++++++++ kklib/include/kklib/ref.h | 93 ++++++++++ kklib/include/kklib/vector.h | 115 ++++++++++++ 4 files changed, 339 insertions(+), 294 deletions(-) create mode 100644 kklib/include/kklib/maybe.h create mode 100644 kklib/include/kklib/ref.h create mode 100644 kklib/include/kklib/vector.h diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index f913b662c..893c6e650 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -45,7 +45,6 @@ #include "kklib/platform.h" // Platform abstractions and portability definitions #include "kklib/atomic.h" // Atomic operations -#include "kklib/process.h" // Process info (memory usage, run time etc.) /*-------------------------------------------------------------------------------------- @@ -169,9 +168,9 @@ typedef struct kk_datatype_s { typedef kk_datatype_t kk_datatype_ptr_t; // boxed forward declarations -static inline kk_intf_t kk_intf_unbox(kk_box_t v); -static inline kk_box_t kk_intf_box(kk_intf_t u); - +static inline kk_intf_t kk_intf_unbox(kk_box_t b); +static inline kk_box_t kk_intf_box(kk_intf_t i); +static inline bool kk_box_is_any(kk_box_t b); /*-------------------------------------------------------------------------------------- Blocks @@ -1186,43 +1185,15 @@ static inline kk_datatype_t kk_datatype_ptr_unbox_assert(kk_box_t b, kk_tag_t t, } -/*---------------------------------------------------------------------- - Further includes -----------------------------------------------------------------------*/ +/*-------------------------------------------------------------------------------------- + kk_Unit +--------------------------------------------------------------------------------------*/ // The unit type typedef enum kk_unit_e { kk_Unit = 0 } kk_unit_t; -#include "kklib/bits.h" -#include "kklib/box.h" -#include "kklib/integer.h" -#include "kklib/bytes.h" -#include "kklib/string.h" -#include "kklib/random.h" -#include "kklib/os.h" -#include "kklib/thread.h" - - -/*---------------------------------------------------------------------- - Thread local context operations -----------------------------------------------------------------------*/ - -// Get a thread local unique number. -static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { - kk_integer_t u = ctx->unique; - ctx->unique = kk_integer_inc(kk_integer_dup(u,ctx),ctx); - return u; -} - -kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); - - -/*-------------------------------------------------------------------------------------- - kk_Unit ---------------------------------------------------------------------------------------*/ - static inline kk_decl_const kk_box_t kk_unit_box(kk_unit_t u) { return kk_intf_box((kk_intf_t)u); } @@ -1233,7 +1204,6 @@ static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { return kk_Unit; // (kk_unit_t)kk_enum_unbox(u); } - /*-------------------------------------------------------------------------------------- Functions --------------------------------------------------------------------------------------*/ @@ -1288,184 +1258,62 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) /*-------------------------------------------------------------------------------------- - Vector + TRMC (Further primitives are defined in `lib/std/core/types-ctail-inline.h`) --------------------------------------------------------------------------------------*/ -typedef struct kk_vector_large_s { // always use a large block for a vector so the offset to the elements is fixed - struct kk_block_large_s _base; - kk_box_t vec[1]; // vec[(large_)scan_fsize - 1] -} *kk_vector_large_t; - - -static inline kk_decl_const kk_vector_t kk_vector_empty(void) { - return kk_datatype_from_tag((kk_tag_t)1); -} - -static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v, kk_context_t* ctx) { - if (kk_datatype_is_singleton(v)) { - return NULL; - } - else { - return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR, ctx); - } -} - -static inline void kk_vector_drop(kk_vector_t v, kk_context_t* ctx) { - kk_datatype_drop(v, ctx); -} - -static inline kk_vector_t kk_vector_dup(kk_vector_t v, kk_context_t* ctx) { - return kk_datatype_dup(v,ctx); -} - -static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { - if kk_unlikely(length<=0) { - if (buf != NULL) *buf = NULL; - return kk_vector_empty(); - } - else { - kk_vector_large_t v = (kk_vector_large_t)kk_block_large_alloc( - kk_ssizeof(struct kk_vector_large_s) + (length-1)*kk_ssizeof(kk_box_t), // length-1 as the vector_large_s already includes one element - length + 1, // +1 to include the kk_large_scan_fsize field itself - KK_TAG_VECTOR, ctx); - if (buf != NULL) *buf = &v->vec[0]; - return kk_datatype_from_base(&v->_base,ctx); - } -} - -kk_decl_export void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx); -kk_decl_export kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx); -kk_decl_export kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx); - -static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_context_t* ctx) { - kk_vector_t v = kk_vector_alloc_uninit(length, NULL, ctx); - kk_vector_init_borrow(v, 0, def, ctx); - return v; -} - -static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len, kk_context_t* ctx) { - kk_vector_large_t v = kk_vector_as_large_borrow(vd,ctx); - if kk_unlikely(v==NULL) { - if (len != NULL) *len = 0; - return NULL; - } - else { - if (len != NULL) { - *len = (kk_ssize_t)kk_intf_unbox(v->_base.large_scan_fsize) - 1; // exclude the large scan_fsize field itself - kk_assert_internal(*len + 1 == kk_block_scan_fsize(&v->_base._block)); - kk_assert_internal(*len > 0); - } - return &(v->vec[0]); - } -} - -static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v, kk_context_t* ctx) { - kk_ssize_t len; - kk_vector_buf_borrow(v, &len, ctx); - return len; -} - -static inline kk_ssize_t kk_vector_len(const kk_vector_t v, kk_context_t* ctx) { - kk_ssize_t len = kk_vector_len_borrow(v,ctx); - kk_vector_drop(v, ctx); - return len; -} - -static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i, kk_context_t* ctx) { - kk_assert(i < kk_vector_len_borrow(v,ctx)); - kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL, ctx)[i],ctx); - return res; -} +#if !defined(KK_HAS_MALLOC_COPY) +#define KK_CTAIL_NO_CONTEXT_PATH +#else -static inline kk_decl_const kk_box_t kk_vector_box(kk_vector_t v, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_box(v); -} +// functional context composition by copying along the context path and attaching `child` at the hole. +kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); -static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_unbox(v); +// update the field_idx with the field index + 1 that is along the context path, and return `d` as is. +static inline kk_datatype_t kk_ctail_set_context_path(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { + kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); + kk_assert_internal(kk_datatype_is_ptr(d)); + const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); + kk_assert_internal(field_index <= KK_SCAN_FSIZE_MAX - 2); + kk_block_field_idx_set( kk_datatype_as_ptr(d,ctx), 1 + (uint8_t)field_index); + return d; } +#endif -/*-------------------------------------------------------------------------------------- - References ---------------------------------------------------------------------------------------*/ - -struct kk_ref_s { - kk_block_t _block; - _Atomic(kk_intb_t) value; -}; -typedef kk_datatype_ptr_t kk_ref_t; - -kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx); -kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value); -kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); -static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_ptr_box(r); -} +/*---------------------------------------------------------------------- + Further primitive datatypes and api's +----------------------------------------------------------------------*/ -static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_ptr_unbox_assert(b, KK_TAG_REF, ctx); -} +#include "kklib/bits.h" +#include "kklib/box.h" -static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { - kk_datatype_ptr_drop_assert(r, KK_TAG_REF, ctx); -} +#include "kklib/maybe.h" +#include "kklib/integer.h" +#include "kklib/bytes.h" +#include "kklib/string.h" +#include "kklib/ref.h" +#include "kklib/vector.h" -static inline kk_ref_t kk_ref_dup(kk_ref_t r, kk_context_t* ctx) { - return kk_datatype_ptr_dup_assert(r, KK_TAG_REF, ctx); -} +#include "kklib/random.h" +#include "kklib/os.h" +#include "kklib/thread.h" +#include "kklib/process.h" // Process info (memory usage, run time etc.) -static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { - struct kk_ref_s* r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); - kk_atomic_store_relaxed(&r->value,value.box); - return kk_datatype_from_base(r,ctx); -} -static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { - struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); - if kk_likely(!kk_block_is_thread_shared(&r->_block)) { - // fast path - kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); - kk_box_dup(b,ctx); - kk_block_drop(&r->_block,ctx); // TODO: make references borrowed (only get left) - return b; - } - else { - // thread shared - return kk_ref_get_thread_shared(r,ctx); - } -} - -static inline kk_box_t kk_ref_swap_borrow(kk_ref_t _r, kk_box_t value, kk_context_t* ctx) { - struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); - if kk_likely(!kk_block_is_thread_shared(&r->_block)) { - // fast path - kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); - kk_atomic_store_relaxed(&r->value, value.box); - return b; - } - else { - // thread shared - return kk_ref_swap_thread_shared_borrow(r, value); - } -} +/*---------------------------------------------------------------------- + Thread local context operations +----------------------------------------------------------------------*/ -static inline kk_unit_t kk_ref_set_borrow(kk_ref_t r, kk_box_t value, kk_context_t* ctx) { - kk_box_t b = kk_ref_swap_borrow(r, value, ctx); - kk_box_drop(b, ctx); - return kk_Unit; +// Get a thread local unique number. +static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { + kk_integer_t u = ctx->unique; + ctx->unique = kk_integer_inc(kk_integer_dup(u,ctx),ctx); + return u; } -// In Koka we can constrain the argument of f to be a local-scope reference. -static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* ctx) { - return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx),ctx); -} +kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); /*-------------------------------------------------------------------------------------- @@ -1483,101 +1331,4 @@ static inline kk_decl_const bool kk_value_tag_eq(kk_value_tag_t x, kk_value_tag_ } -/*-------------------------------------------------------------------------------------- - Optimized support for maybe like datatypes. - We try to avoid allocating for maybe-like types. First we define maybe as a value - type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag - and payload. This does not help though if it becomes boxed, say, a list of maybe - values. In that case we can still avoid allocation through the special TAG_NOTHING - and TAG_JUST tags. If the Just value is neither of those, we just use it directly - without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) - are allocated, and sometimes value types like `int32` if these happen to be equal - to `kk_box_Nothing`. ---------------------------------------------------------------------------------------*/ - -static inline kk_box_t kk_box_Nothing(void) { - return kk_datatype_box(kk_datatype_from_tag(KK_TAG_NOTHING)); -} - -static inline bool kk_box_is_Nothing(kk_box_t b) { - return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); -} - -static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b, ctx), KK_TAG_JUST)); -} - -static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { - return (kk_box_is_Just(b, ctx) || kk_box_is_Nothing(b)); -} - -typedef struct kk_just_s { - struct kk_block_s _block; - kk_box_t value; -} kk_just_t; - -kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_context_t* ctx); - -static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_context_t* ctx) { - if (kk_box_is_ptr(b)) { - kk_block_t* bl = kk_ptr_unbox(b, ctx); - if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { - return kk_unbox_Just_block(bl, ctx); - } - } - // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b - return b; -} - -static inline kk_box_t kk_box_Just(kk_box_t b, kk_context_t* ctx) { - if kk_likely(!kk_box_is_maybe(b, ctx)) { - return b; - } - else { - kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); - just->value = b; - return kk_ptr_box(&just->_block, ctx); - } -} - -static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { - kk_assert_internal(!kk_box_is_maybe(b, kk_get_context())); - return kk_datatype_unbox(b); -} - -static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { - kk_unused(ctx); - kk_assert_internal(!kk_datatype_has_singleton_tag(d, KK_TAG_NOTHING)); - if (kk_datatype_is_ptr(d)) { - kk_block_t* b = kk_datatype_as_ptr(d, ctx); - if (kk_block_has_tag(b, KK_TAG_JUST)) { - return kk_block_field(b, 0); - } - } - return kk_datatype_box(d); -} - - -/*-------------------------------------------------------------------------------------- - TRMC (Further primitives are defined in `lib/std/core/types-ctail-inline.h`) ---------------------------------------------------------------------------------------*/ - -#if !defined(KK_HAS_MALLOC_COPY) -#define KK_CTAIL_NO_CONTEXT_PATH -#else - -// functional context composition by copying along the context path and attaching `child` at the hole. -kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); - -// update the field_idx with the field index + 1 that is along the context path, and return `d` as is. -static inline kk_datatype_t kk_ctail_set_context_path(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { - kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); - kk_assert_internal(kk_datatype_is_ptr(d)); - const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); - kk_block_field_idx_set( kk_datatype_as_ptr(d,ctx), 1 + field_index); - return d; -} - -#endif - #endif // include guard diff --git a/kklib/include/kklib/maybe.h b/kklib/include/kklib/maybe.h new file mode 100644 index 000000000..ac515f4de --- /dev/null +++ b/kklib/include/kklib/maybe.h @@ -0,0 +1,86 @@ +#pragma once +#ifndef KK_MAYBE_H +#define KK_MAYBE_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +/*-------------------------------------------------------------------------------------- + Optimized support for maybe like datatypes. + We try to avoid allocating for maybe-like types. First we define maybe as a value + type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag + and payload. This does not help though if it becomes boxed, say, a list of maybe + values. In that case we can still avoid allocation through the special TAG_NOTHING + and TAG_JUST tags. If the Just value is neither of those, we just use it directly + without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) + are allocated, and sometimes value types like `int32` if these happen to be equal + to `kk_box_Nothing`. +--------------------------------------------------------------------------------------*/ + +static inline kk_box_t kk_box_Nothing(void) { + return kk_datatype_box(kk_datatype_from_tag(KK_TAG_NOTHING)); +} + +static inline bool kk_box_is_Nothing(kk_box_t b) { + return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); +} + +static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b, ctx), KK_TAG_JUST)); +} + +static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_Just(b, ctx) || kk_box_is_Nothing(b)); +} + +typedef struct kk_just_s { + struct kk_block_s _block; + kk_box_t value; +} kk_just_t; + +kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_context_t* ctx); + +static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_ptr(b)) { + kk_block_t* bl = kk_ptr_unbox(b, ctx); + if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { + return kk_unbox_Just_block(bl, ctx); + } + } + // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b + return b; +} + +static inline kk_box_t kk_box_Just(kk_box_t b, kk_context_t* ctx) { + if kk_likely(!kk_box_is_maybe(b, ctx)) { + return b; + } + else { + kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); + just->value = b; + return kk_ptr_box(&just->_block, ctx); + } +} + +static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { + kk_assert_internal(!kk_box_is_maybe(b, kk_get_context())); + return kk_datatype_unbox(b); +} + +static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { + kk_unused(ctx); + kk_assert_internal(!kk_datatype_has_singleton_tag(d, KK_TAG_NOTHING)); + if (kk_datatype_is_ptr(d)) { + kk_block_t* b = kk_datatype_as_ptr(d, ctx); + if (kk_block_has_tag(b, KK_TAG_JUST)) { + return kk_block_field(b, 0); + } + } + return kk_datatype_box(d); +} + +#endif // KK_MAYBE_H diff --git a/kklib/include/kklib/ref.h b/kklib/include/kklib/ref.h new file mode 100644 index 000000000..7038009d9 --- /dev/null +++ b/kklib/include/kklib/ref.h @@ -0,0 +1,93 @@ +#pragma once +#ifndef KK_REF_H +#define KK_REF_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +/*-------------------------------------------------------------------------------------- + Mutable references cells +--------------------------------------------------------------------------------------*/ + +struct kk_ref_s { + kk_block_t _block; + _Atomic(kk_intb_t) value; +}; +typedef kk_datatype_ptr_t kk_ref_t; + +kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx); +kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value); +kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); + +static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_box(r); +} + +static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_unbox_assert(b, KK_TAG_REF, ctx); +} + +static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { + kk_datatype_ptr_drop_assert(r, KK_TAG_REF, ctx); +} + +static inline kk_ref_t kk_ref_dup(kk_ref_t r, kk_context_t* ctx) { + return kk_datatype_ptr_dup_assert(r, KK_TAG_REF, ctx); +} + +static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); + kk_atomic_store_relaxed(&r->value,value.box); + return kk_datatype_from_base(r,ctx); +} + +static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { + // fast path + kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); + kk_box_dup(b,ctx); + kk_block_drop(&r->_block,ctx); // TODO: make references borrowed (only get left) + return b; + } + else { + // thread shared + return kk_ref_get_thread_shared(r,ctx); + } +} + +static inline kk_box_t kk_ref_swap_borrow(kk_ref_t _r, kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { + // fast path + kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); + kk_atomic_store_relaxed(&r->value, value.box); + return b; + } + else { + // thread shared + return kk_ref_swap_thread_shared_borrow(r, value); + } +} + + +static inline kk_unit_t kk_ref_set_borrow(kk_ref_t r, kk_box_t value, kk_context_t* ctx) { + kk_box_t b = kk_ref_swap_borrow(r, value, ctx); + kk_box_drop(b, ctx); + return kk_Unit; +} + +// In Koka we can constrain the argument of f to be a local-scope reference. +static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* ctx) { + return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx),ctx); +} + + + +#endif // KK_REF_H diff --git a/kklib/include/kklib/vector.h b/kklib/include/kklib/vector.h new file mode 100644 index 000000000..2eb1ff55a --- /dev/null +++ b/kklib/include/kklib/vector.h @@ -0,0 +1,115 @@ +#pragma once +#ifndef KK_VECTOR_H +#define KK_VECTOR_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + + +/*-------------------------------------------------------------------------------------- + Vectors : arrays of boxed values +--------------------------------------------------------------------------------------*/ + +typedef struct kk_vector_large_s { // always use a large block for a vector so the offset to the elements is fixed + struct kk_block_large_s _base; + kk_box_t vec[1]; // vec[(large_)scan_fsize - 1] +} *kk_vector_large_t; + + +static inline kk_decl_const kk_vector_t kk_vector_empty(void) { + return kk_datatype_from_tag((kk_tag_t)1); +} + +static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v, kk_context_t* ctx) { + if (kk_datatype_is_singleton(v)) { + return NULL; + } + else { + return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR, ctx); + } +} + +static inline void kk_vector_drop(kk_vector_t v, kk_context_t* ctx) { + kk_datatype_drop(v, ctx); +} + +static inline kk_vector_t kk_vector_dup(kk_vector_t v, kk_context_t* ctx) { + return kk_datatype_dup(v,ctx); +} + +static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { + if kk_unlikely(length<=0) { + if (buf != NULL) *buf = NULL; + return kk_vector_empty(); + } + else { + kk_vector_large_t v = (kk_vector_large_t)kk_block_large_alloc( + kk_ssizeof(struct kk_vector_large_s) + (length-1)*kk_ssizeof(kk_box_t), // length-1 as the vector_large_s already includes one element + length + 1, // +1 to include the kk_large_scan_fsize field itself + KK_TAG_VECTOR, ctx); + if (buf != NULL) *buf = &v->vec[0]; + return kk_datatype_from_base(&v->_base,ctx); + } +} + +kk_decl_export void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx); +kk_decl_export kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx); +kk_decl_export kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx); + +static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_context_t* ctx) { + kk_vector_t v = kk_vector_alloc_uninit(length, NULL, ctx); + kk_vector_init_borrow(v, 0, def, ctx); + return v; +} + +static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len, kk_context_t* ctx) { + kk_vector_large_t v = kk_vector_as_large_borrow(vd,ctx); + if kk_unlikely(v==NULL) { + if (len != NULL) *len = 0; + return NULL; + } + else { + if (len != NULL) { + *len = (kk_ssize_t)kk_intf_unbox(v->_base.large_scan_fsize) - 1; // exclude the large scan_fsize field itself + kk_assert_internal(*len + 1 == kk_block_scan_fsize(&v->_base._block)); + kk_assert_internal(*len > 0); + } + return &(v->vec[0]); + } +} + +static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v, kk_context_t* ctx) { + kk_ssize_t len; + kk_vector_buf_borrow(v, &len, ctx); + return len; +} + +static inline kk_ssize_t kk_vector_len(const kk_vector_t v, kk_context_t* ctx) { + kk_ssize_t len = kk_vector_len_borrow(v,ctx); + kk_vector_drop(v, ctx); + return len; +} + +static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i, kk_context_t* ctx) { + kk_assert(i < kk_vector_len_borrow(v,ctx)); + kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL, ctx)[i],ctx); + return res; +} + +static inline kk_decl_const kk_box_t kk_vector_box(kk_vector_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_box(v); +} + +static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_unbox(v); +} + + + +#endif // KK_VECTOR_H From ab547f2682ce89494df544d3678dad123dc9040c Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 15 Dec 2022 10:50:01 -0800 Subject: [PATCH 108/233] add 128-bit and cheri support for pointer compression --- kklib/include/kklib.h | 123 ++++++++++++++++++++++----------- kklib/include/kklib/bits.h | 8 +-- kklib/include/kklib/box.h | 2 +- kklib/include/kklib/platform.h | 15 +++- kklib/src/init.c | 25 ++++--- 5 files changed, 115 insertions(+), 58 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 893c6e650..ecd45bfb7 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 97 // modify on changes to trigger recompilation +#define KKLIB_BUILD 97 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -405,29 +405,30 @@ typedef struct kk_yield_s { // The thread local context. // The fields `yielding`, `heap` and `evv` should come first for efficiency typedef struct kk_context_s { - int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency - const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? - const intptr_t heap_base; // mid point of the reserved heap address space (or 0 if the heap is not compressed) - kk_datatype_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector - kk_yield_t yield; // inlined yield structure (for efficiency) - int32_t marker_unique; // unique marker generation - kk_block_t* delayed_free; // list of blocks that still need to be freed - kk_integer_t unique; // thread local unique number generation - size_t thread_id; // unique thread id - kk_box_any_t kk_box_any; // used when yielding as a value of any type - kk_function_t log; // logging function - kk_function_t out; // std output - kk_task_group_t* task_group; // task group for managing threads. NULL for the main thread. + int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency + const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? + const intptr_t heap_mid; // mid point of the reserved heap address space (or 0 if the heap is not compressed) + const void* heap_start; // bottom of the heap (or NULL if the heap is not compressed) + kk_datatype_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector + kk_yield_t yield; // inlined yield structure (for efficiency) + int32_t marker_unique; // unique marker generation + kk_block_t* delayed_free; // list of blocks that still need to be freed + kk_integer_t unique; // thread local unique number generation + size_t thread_id; // unique thread id + kk_box_any_t kk_box_any; // used when yielding as a value of any type + kk_function_t log; // logging function + kk_function_t out; // std output + kk_task_group_t* task_group; // task group for managing threads. NULL for the main thread. - struct kk_random_ctx_s* srandom_ctx; // strong random using chacha20, initialized on demand - kk_ssize_t argc; // command line argument count - const char** argv; // command line arguments - kk_duration_t process_start; // time at start of the process - int64_t timer_freq; // high precision timer frequency - kk_duration_t timer_prev; // last requested timer time - kk_duration_t timer_delta; // applied timer delta (to ensure monotonicity) - int64_t time_freq; // unix time frequency - kk_duration_t time_unix_prev; // last requested unix time + struct kk_random_ctx_s* srandom_ctx;// strong random using chacha20, initialized on demand + kk_ssize_t argc; // command line argument count + const char** argv; // command line arguments + kk_duration_t process_start; // time at start of the process + int64_t timer_freq; // high precision timer frequency + kk_duration_t timer_prev; // last requested timer time + kk_duration_t timer_delta; // applied timer delta (to ensure monotonicity) + int64_t time_freq; // unix time frequency + kk_duration_t time_unix_prev; // last requested unix time } kk_context_t; // Get the current (thread local) runtime context (should always equal the `_ctx` parameter) @@ -884,39 +885,81 @@ static inline bool kk_is_value(kk_intb_t i) { // If we assume `intptr_t` aligned pointers in the heap, we can use a larger heap when // using pointer compression (by shifting them by `KK_BOX_PTR_SHIFT`). -#if !defined(KK_BOX_PTR_SHIFT) -#define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) +#if !defined(KK_BOX_PTR_SHIFT) + #if (KK_INTB_SIZE <= 4) + // shift by pointer alignment if we have at most 32-bit boxed ints + #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) + #else + // don't bother with shifting if we have more than 32 bits available + #define KK_BOX_PTR_SHIFT (0) + #endif #endif // Without compression, pointer encode/decode is an identity operation. static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { - kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); - intptr_t i = (intptr_t)p; + kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); #if KK_COMPRESS - i = i - ctx->heap_base; - #if KK_BOX_PTR_SHIFT > 0 - i = kk_sarp(i, KK_BOX_PTR_SHIFT); - #endif -#else + #if KK_CHERI + // arm CHERI for 32-bit or 64-bit kk_intb_t; all pointers are relative to the heap + kk_assert_internal(__builtin_cheri_base_get(p) == __builtin_cheri_address_get(ctx->heap_base)); kk_unused_internal(ctx); + size_t ofs = __builtin_cheri_offset_get(p); + #if KK_BOX_PTR_SHIFT > 0 + ofs = (ofs >> KK_BOX_PTR_SHIFT); + #endif + kk_assert_internal(ofs <= KK_UINTB_MAX); + kk_intb_t i = (kk_intb_t)ofs; + #elif (KK_INTB_SIZE==4) + // compress to 32-bit offsets, ctx->heap_mid contains the mid-point in the heap so we can do signed extension + intptr_t i = (intptr_t)p - ctx->heap_mid; + #if KK_BOX_PTR_SHIFT > 0 + i = kk_sarp(i, KK_BOX_PTR_SHIFT); + #endif + #elif (KK_INTB_SIZE==8) + // 128-bit system with 64-bit pointers; we only need to assume that our heap is located in the lower 2^63 adress space + kk_unused(ctx) + intptr_t i = (intptr_t)p; + #else + #error "define pointer compression for this platform" + #endif +#else // |kk_intb_t| == |intptr_t| kk_unused(ctx); + intptr_t i = (intptr_t)p; #endif kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); + kk_assert_internal((i & KK_TAG_MASK) == 0); return ((kk_intb_t)i | KK_TAG_PTR); } static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { kk_assert_internal(kk_is_ptr(b)); - intptr_t i = (b & ~KK_TAG_PTR); -#if KK_COMPRESS - #if KK_BOX_PTR_SHIFT > 0 - kk_assert_internal((i & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); - i = kk_shlp(i, KK_BOX_PTR_SHIFT); + b = (b & ~KK_TAG_PTR); +#if KK_COMPRESS + #if KK_CHERI + // arm CHERI for 32-bit or 64-bit kk_intb_t; all pointers are relative to the heap base + size_t ofs = (size_t)b; + #if (KK_BOX_PTR_SHIFT > 0) + ofs = (ofs << KK_BOX_PTR_SHIFT); + #endif + return (kk_ptr_t)__builtin_cheri_offset_set(ctx->heap_base, ofs); + #elif (KK_INTB_SIZE == 4) + // decompress from 32-bit offsets + intptr_t i = b; // b sign-extends + #if (KK_BOX_PTR_SHIFT > 0) + kk_assert_internal((i & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); + i = kk_shlp(i, KK_BOX_PTR_SHIFT); + #endif + return (kk_ptr_t)(i + ctx->heap_mid); + #elif (KK_INTB_SIZE==8) + // 128-bit system with 64-bit compressed pointers; we only need to assume that our heap is located in the first 2^63 addresses. + kk_unused(ctx); + return (kk_ptr_t)((intptr_t)b); // ensure b sign-extends + #else + #error "define pointer decompression for this platform" #endif - i = i + ctx->heap_base; -#else +#else // |kk_intb_t| == |intptr_t| kk_unused(ctx); + return (kk_ptr_t)b; #endif - return (kk_ptr_t)i; } // Integer value encoding/decoding. May use smaller integers (`kk_intf_t`) diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index 70d0e649b..d546ea255 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -527,12 +527,12 @@ static inline uint8_t kk_bits_digits(kk_uintx_t x) { static inline int32_t kk_bits_midpoint32( int32_t x, int32_t y ) { if kk_likely(x <= y) return x + (int32_t)(((uint32_t)y - (uint32_t)x)/2); - else return x - (int32_t)(((uint32_t)x - (uint32_t)y)/2); + else return x - (int32_t)(((uint32_t)x - (uint32_t)y)/2); } static inline int64_t kk_bits_midpoint64(int64_t x, int64_t y) { if kk_likely(x <= y) return x + (int64_t)(((uint64_t)y - (uint64_t)x)/2); - else return x - (int64_t)(((uint64_t)x - (uint64_t)y)/2); + else return x - (int64_t)(((uint64_t)x - (uint64_t)y)/2); } static inline kk_intx_t kk_bits_midpoint(kk_intx_t x, kk_intx_t y) { @@ -541,12 +541,12 @@ static inline kk_intx_t kk_bits_midpoint(kk_intx_t x, kk_intx_t y) { static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { if kk_likely(x <= y) return (x + (y-x)/2); - else return (x - (x-y)/2); + else return (x - (x-y)/2); } static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { if kk_likely(x <= y) return (x + (y-x)/2); - else return (x - (x-y)/2); + else return (x - (x-y)/2); } static inline kk_uintx_t kk_bits_umidpoint( kk_uintx_t x, kk_uintx_t y ) { diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 05699352c..76a7ed925 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -115,7 +115,7 @@ static inline bool kk_box_is_any(kk_box_t b) { static inline kk_box_t kk_box_from_potential_null_ptr(kk_block_t* p, kk_context_t* ctx) { if (p == NULL) return kk_box_null(); - else return kk_box_from_ptr(p,ctx); + else return kk_box_from_ptr(p,ctx); } static inline kk_block_t* kk_box_to_potential_null_ptr(kk_box_t b, kk_context_t* ctx) { diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 2fd445c63..2bb495830 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -213,6 +213,9 @@ #define kk_likely(x) (x) #endif +// assign const field in a struct +#define kk_assign_const(tp,field) ((tp*)&(field))[0] + // Assertions; kk_assert_internal is only enabled when KK_DEBUG_FULL is defined #define kk_assert(x) assert(x) #ifdef KK_DEBUG_FULL @@ -236,6 +239,10 @@ #endif #endif +#define KK_KiB (1024) +#define KK_MiB (1024L*KK_KiB) +#define KK_GiB (1024L*KK_MiB) + // Defining constants of a specific size #if LONG_MAX == INT64_MAX # define KK_LONG_SIZE 8 @@ -388,7 +395,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE KK_INTPTR_SIZE +#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) @@ -403,7 +410,8 @@ typedef uintptr_t kk_uintb_t; #define KK_IB(i) KK_IP(i) #define KK_UB(i) KK_UP(i) #define PRIdIB "zd" -#elif (KK_INTB_SIZE == 8 && KK_INTB_SIZE < KK_INTPTR_SIZE) +#elif (KK_INTB_SIZE == 8 && KK_INTB_SIZE < KK_INTPTR_SIZE) +// 128-bit systems with 64-bit compressed pointers #define KK_COMPRESS 1 typedef int64_t kk_intb_t; typedef uint64_t kk_uintb_t; @@ -413,7 +421,8 @@ typedef uint64_t kk_uintb_t; #define KK_IB(i) KK_I64(i) #define KK_UB(i) KK_U64(i) #define PRIdIB PRIdI64 -#elif (KK_INTB_SIZE == 4 && KK_INTB_SIZE < KK_INTPTR_SIZE) +#elif (KK_INTB_SIZE == 4 && KK_INTB_SIZE < KK_INTPTR_SIZE) +// 64- or 128-bit systems with 32-bit compressed pointers (and a 4*4GiB heap) #define KK_COMPRESS 1 typedef int32_t kk_intb_t; typedef uint32_t kk_uintb_t; diff --git a/kklib/src/init.c b/kklib/src/init.c index 29ff65c6e..ec1d52bf8 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -150,11 +150,12 @@ void kk_unsupported_external(const char* msg) { --------------------------------------------------------------------------------------------------*/ static bool process_initialized; // = false -#if KK_COMPRESS +#if KK_COMPRESS && (KK_INTB_SIZE==4 || KK_CHERI) #if defined(KK_MIMALLOC) #define KK_USE_MEM_ARENA 1 static mi_arena_id_t arena; - static intptr_t arena_base; + static void* arena_start; + static size_t arena_size; #else #error "can only use compressed heaps with the mimalloc allocator enabled" #endif @@ -199,14 +200,18 @@ static void kklib_init(void) { atexit(&kklib_done); #if KK_USE_MEM_ARENA - const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTF_SIZE * 8 + KK_BOX_PTR_SHIFT); + #if (KK_INTB_SIZE==4) + const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTB_BITS + KK_BOX_PTR_SHIFT); + #elif KK_CHERI && (KK_INTB_SIZE==8) + const kk_ssize_t heap_size = 128 * KK_GiB; // todo: parameterize? + #else + #error "define heap initialization for compressed pointers on this platform" + #endif int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); if (err != 0) { - kk_fatal_error(err, "unable to reserve the initial heap"); + kk_fatal_error(err, "unable to reserve the initial heap of %zi bytes", heap_size); } - size_t arena_size; - void* arena_start = mi_arena_area(arena, &arena_size); - arena_base = (intptr_t)arena_start + (intptr_t)(arena_size / 2); + arena_start = mi_arena_area(arena, &arena_size); #endif } @@ -217,8 +222,6 @@ static void kklib_init(void) { // The thread local context; usually passed explicitly for efficiency. static kk_decl_thread kk_context_t* context; -#define kk_assign_const(tp,field) ((tp*)&(field))[0] - static struct { kk_block_t _block; kk_integer_t cfc; } kk_evv_empty_static = { { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UB(0))^0x02) /*==-1 smallint*/} }; @@ -245,10 +248,12 @@ kk_context_t* kk_get_context(void) { if (ctx!=NULL) return ctx; kklib_init(); #if KK_USE_MEM_ARENA + kk_assert_internal(arena != 0 && arena_start != NULL); mi_heap_t* heap = mi_heap_new_in_arena(arena); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); kk_assign_const(kk_heap_t,ctx->heap) = heap; - kk_assign_const(intptr_t, ctx->heap_base) = arena_base; + kk_assign_const(void*, ctx->heap_start) = arena_start; + kk_assign_const(intptr_t, ctx->heap_mid) = (intptr_t)arena_start + (intptr_t)(arena_size / 2); #elif defined(KK_MIMALLOC) mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); From 01301f001d21e8aded1f078d870762ceafb1f05e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 30 Dec 2022 15:58:57 -0800 Subject: [PATCH 109/233] bump mimalloc; cleanup BOX_MIN/MAX macros --- kklib/include/kklib.h | 14 ++++++++------ kklib/include/kklib/box.h | 6 +++--- kklib/include/kklib/integer.h | 18 ++++++++---------- kklib/include/kklib/platform.h | 2 +- kklib/mimalloc | 2 +- kklib/src/box.c | 10 +++++----- 6 files changed, 26 insertions(+), 26 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index ecd45bfb7..23143e742 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 97 // modify on changes to trigger recompilation +#define KKLIB_BUILD 99 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -964,14 +964,16 @@ static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { // Integer value encoding/decoding. May use smaller integers (`kk_intf_t`) // then boxed integers if `kk_intb_t` is larger than the natural register size. -#define KK_INTF_BOX_MAX ((kk_intf_t)KK_INTF_MAX >> KK_TAG_BITS) -#define KK_INTF_BOX_MIN (-KK_INTF_BOX_MAX - 1) -#define KK_UINTF_BOX_MAX ((kk_uintf_t)KK_UINTF_MAX >> KK_TAG_BITS) +#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - KK_TAG_BITS + (extra)) +#define KK_INTF_BOX_MAX(extra) (KK_INTF_MAX >> (KK_TAG_BITS + (extra))) +#define KK_INTF_BOX_MIN(extra) (-KK_INTF_BOX_MAX(extra) - 1) +#define KK_UINTF_BOX_MAX(extra) (KK_UINTF_MAX >> (KK_TAG_BITS + (extra))) static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { kk_assert_internal(extra_shift >= 0); - kk_assert_internal(i >= (KK_INTF_BOX_MIN / (KK_IF(1)<= KK_INTF_BOX_MIN(extra_shift) && i <= KK_INTF_BOX_MAX(extra_shift)); + return (kk_shlb(b,KK_TAG_BITS + extra_shift) | KK_TAG_VALUE); } static inline kk_intf_t kk_intf_decode(kk_intb_t b, int extra_shift) { diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 76a7ed925..69cd83a82 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -155,7 +155,7 @@ static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { } static inline kk_box_t kk_uintf_box(kk_uintf_t u) { - kk_assert_internal(u <= KK_UINTF_BOX_MAX); + kk_assert_internal(u <= KK_UINTF_BOX_MAX(0)); kk_intf_t i = kk_sarf(kk_shlf((kk_intf_t)u, KK_TAG_BITS), KK_TAG_BITS); return kk_intf_box(i); } @@ -304,7 +304,7 @@ static inline kk_uintf_t kk_enum_unbox(kk_box_t b) { } static inline kk_box_t kk_enum_box(kk_uintf_t u) { - kk_assert_internal(u <= KK_INTF_BOX_MAX); + kk_assert_internal(u <= KK_INTF_BOX_MAX(0)); return kk_intf_box((kk_intf_t)u); } @@ -404,7 +404,7 @@ static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { f = f - (intptr_t)&kk_main_start; #endif kk_assert(kk_shrp(f, KK_INTPTR_BITS - KK_TAG_BITS) == 0); // assume top bits of function pointer addresses are clear - kk_assert(f >= KK_INTF_BOX_MIN && f <= KK_INTF_BOX_MAX); + kk_assert(f >= KK_INTF_BOX_MIN(0) && f <= KK_INTF_BOX_MAX(0)); kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value return b; } diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 159f0f1f4..bdbc2ee49 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -165,32 +165,30 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. #if KK_INT_ARITHMETIC == KK_INT_USE_OVF || KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF typedef kk_intf_t kk_smallint_t; -#define KK_SMALLINT_BITS (KK_INTF_BITS) +#define KK_SMALLINT_BITS (KK_INTF_BOX_BITS(1)) +#define KK_SMALLINT_MAX (KK_INTF_BOX_MAX(1)) #elif KK_INTF_SIZE>=16 typedef int64_t kk_smallint_t; #define KK_SMALLINT_BITS (64) +#define KK_SMALLINT_MAX (INT64_MAX) #elif KK_INTF_SIZE==8 typedef int32_t kk_smallint_t; #define KK_SMALLINT_BITS (32) +#define KK_SMALLINT_MAX (INT32_MAX) #elif KK_INTF_SIZE==4 typedef int16_t kk_smallint_t; #define KK_SMALLINT_BITS (16) +#define KK_SMALLINT_MAX (INT16_MAX) #elif KK_INTF_SIZE==2 typedef int8_t kk_smallint_t; #define KK_SMALLINT_BITS (8) +#define KK_SMALLINT_MAX (INT8_MAX) #else # error "platform must be 16, 32, 64, or 128 bits." #endif -#if KK_INT_ARITHMETIC != KK_INT_USE_RENO -#define KK_INT_TAG_BITS (2) -#else -#define KK_INT_TAG_BITS (0) -#endif - -#define KK_SMALLINT_SIZE (KK_SMALLINT_BITS/8) -#define KK_SMALLINT_MAX (KK_INTF_MAX >> (KK_INTF_BITS - KK_SMALLINT_BITS + KK_INT_TAG_BITS)) -#define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) +#define KK_SMALLINT_SIZE (KK_SMALLINT_BITS/8) +#define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) static inline bool kk_is_smallint(kk_integer_t i) { return kk_is_value(i.ibox); diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 2bb495830..4eb03c083 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -395,7 +395,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE +#define KK_INTB_SIZE KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) diff --git a/kklib/mimalloc b/kklib/mimalloc index 447c2f18c..28cf67e5b 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit 447c2f18c56cef4455ab9db1d5f713f6203753a8 +Subproject commit 28cf67e5b64c704cad993c71f29a24e781bee544 diff --git a/kklib/src/box.c b/kklib/src/box.c index fdda7a2eb..c64597473 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -43,7 +43,7 @@ intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx) { - if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { return kk_intf_box((kk_intf_t)i); } else { @@ -75,7 +75,7 @@ int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { - if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { return kk_intf_box((kk_intf_t)i); } else { @@ -109,7 +109,7 @@ int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { } kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { - if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { return kk_intf_box(i); } else { @@ -206,7 +206,7 @@ void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx) { kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { intptr_t i = (intptr_t)p; - if kk_likely(i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { + if kk_likely(i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { // box as value return kk_intf_box((kk_intf_t)i); } @@ -383,7 +383,7 @@ static kk_box_t kk_float_box_heap(float f, kk_context_t* ctx) { kk_box_t kk_float_box(float f, kk_context_t* ctx) { kk_unused(ctx); uint32_t u = kk_bits_from_float(f); - if (u <= KK_UINTF_BOX_MAX) { // fits in a boxed value? (i.e. is the double positive) + if (u <= KK_UINTF_BOX_MAX(0)) { // fits in a boxed value? (i.e. is the double positive) return kk_uintf_box(u); } else { From 963bd1375f152e2b5cd90a96bc6e168e294f0adb Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 1 Jan 2023 18:10:52 -0800 Subject: [PATCH 110/233] make sslice use integers instead of ssize_t --- kklib/include/kklib/integer.h | 9 +++++ kklib/include/kklib/string.h | 4 ++ lib/std/core.kk | 40 ++++++++++---------- lib/std/core/core-inline.c | 69 ++++++++++++++++++++++------------- lib/std/text/regex-inline.c | 8 ++-- test/Spec.hs | 12 +++--- test/parc/parc2.kk.out | 2 +- test/readme.md | 1 + 8 files changed, 90 insertions(+), 55 deletions(-) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index bdbc2ee49..1163391dd 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -947,6 +947,15 @@ static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_con } } +static inline kk_integer_t kk_integer_min_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); + if (kk_integer_lte_borrow(x, y, ctx)) { + return kk_integer_dup(x,ctx); + } + else { + return kk_integer_dup(y,ctx); + } +} /*--------------------------------------------------------------------------------- clamp int to smaller ints diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index 651b64553..90691002d 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -262,6 +262,10 @@ static inline kk_ssize_t kk_decl_pure kk_string_len(kk_string_t str, kk_context_ return len; } +static inline kk_integer_t kk_decl_pure kk_string_len_int(kk_string_t str, kk_context_t* ctx) { // bytes in UTF8 + return kk_integer_from_ssize_t(kk_string_len(str,ctx),ctx); +} + static inline kk_string_t kk_string_copy(kk_string_t str, kk_context_t* ctx) { return kk_unsafe_bytes_as_string(kk_bytes_copy(str.bytes, ctx)); } diff --git a/lib/std/core.kk b/lib/std/core.kk index d5116a6a9..c6d7881a1 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1368,10 +1368,10 @@ pub fun maximum( xs : list ) : float64 // returned by functions that find sub strings or patterns in // in strings. Use `string:(slice : sslice) -> string` to // create a fresh substring from a slice. -abstract struct sslice( str : string, start : ssize_t, len : ssize_t ) +abstract struct sslice( str : string, start : int, len : int ) // Internal export for the regex module -pub fun ".new-sslice"( str :string, start: ssize_t, len : ssize_t ) +pub fun ".new-sslice"( str :string, start: int, len : int ) Sslice(str,start,len) // Convert a character to a string @@ -1442,8 +1442,8 @@ pub fun (||)( x : string, y : string ) : string if x.is-empty then y else x // Length returns the length in the platform specific encoding (and should not be exported) -inline extern length( s : string ) : ssize_t - c inline "kk_string_len(#1,kk_context())" +inline extern length( s : string ) : int + c inline "kk_string_len_int(#1,kk_context())" cs inline "#1.Length" js inline "#1.length" @@ -1482,21 +1482,21 @@ pub fun last(s : string, n : int = 1) : sslice // O(1). The entire string as a slice pub fun slice( s : string ) : sslice - Sslice(s,0.ssize_t,s.length) + Sslice(s,0,s.length) // An empty slice -val empty = Sslice("",0.ssize_t,0.ssize_t) +val empty = Sslice("",0,0) // Is a slice empty? pub fun is-empty( slice : sslice ) : bool !slice.len.is-pos // An invalid slice -val invalid = Sslice("",(-1).ssize_t,0.ssize_t) +val invalid = Sslice("",-1,0) // Is a slice invalid? pub fun is-valid( slice : sslice ) : bool - slice.start >= 0.ssize_t + slice.start >= 0 // Is a slice not empty? pub fun is-notempty( slice : sslice ) : bool @@ -1548,7 +1548,7 @@ pub extern extend( slice : sslice, ^count : int ) : sslice // start of `slice` argument. pub fun before(slice : sslice) : sslice val Sslice(s,start,_len) = slice - Sslice(s,0.ssize_t,start) + Sslice(s,0,start) // O(1). Return the string slice from the end of `slice` argument // to the end of the string. @@ -1598,7 +1598,7 @@ inline extern xindex-of(s : string, sub : string ) : ssize_t // the position just following the substring `sub`. pub fun find( s : string, sub : string ) : maybe val i = s.xindex-of(sub) - if i.is-zero then Nothing else Just(Sslice(s,i.decr,sub.length)) + if i.is-zero then Nothing else Just(Sslice(s,i.decr.int,sub.length)) // Does string `s` contain the string `sub` ? inline extern xlast-index-of(s : string, sub : string ) : ssize_t @@ -1609,7 +1609,7 @@ inline extern xlast-index-of(s : string, sub : string ) : ssize_t // Return the last index of substring `sub` in `s` if it occurs. pub fun find-last( s : string, sub : string ) : maybe val i = s.xlast-index-of(sub) - if i.is-zero then Nothing else Just(Sslice(s,i.decr,sub.length)) + if i.is-zero then Nothing else Just(Sslice(s,i.decr.int,sub.length)) inline extern xstarts-with: (s : string, pre : string ) -> bool c "kk_string_starts_with" @@ -1632,7 +1632,7 @@ extern xends-with: (s : string, post : string ) -> bool // If so, returns a slice of `s` from the start up to the `post` string at the end. pub fun ends-with( s : string, post : string ) : maybe if (xends-with(s,post)) - then Just(Sslice(s,0.ssize_t,s.length - post.length)) + then Just(Sslice(s,0,s.length - post.length)) else Nothing // Does string `s` contain the string `sub` ? @@ -1671,15 +1671,15 @@ pub fun trim-right( s : string, sub : string ) : string Just(slice) -> trim-right(unsafe-decreasing(slice.string),sub) Nothing -> s -// Repeat a string `n` times -pub fun repeat( s : string, ^n : int ) : string - repeatz(s,n.ssize_t) - extern repeatz( s : string, n : ssize_t ) : string c "kk_string_repeat" cs "Primitive.Repeat" js "_string_repeat" +// Repeat a string `n` times +pub fun repeat( s : string, ^n : int ) : string + repeatz(s,n.ssize_t) + // Convert a `:maybe` string to a string using the empty sting for `Nothing` pub fun string( ms : maybe ) : string match ms @@ -1785,19 +1785,19 @@ pub fun capitalize( s : string ) : string // Right-align a string to width `width` using `fill` (default is a space) to fill from the left. pub fun pad-left( s : string, ^width : int, fill : char = ' ') : string - val w = width.ssize_t + val w = width val n = s.length if w <= n then s - else fill.string.repeatz( w - n ) ++ s + else fill.string.repeat( w - n ) ++ s // Left-align a string to width `width` using `fill` (default is a space) to fill on the right. pub fun pad-right( s : string, ^width : int, fill : char = ' ') : string - val w = width.ssize_t + val w = width val n = s.length if w <= n then s - else s ++ fill.string.repeatz(w - n) + else s ++ fill.string.repeat(w - n) // Trim whitespace on the left and right side of a string pub fun trim( s : string ) : string diff --git a/lib/std/core/core-inline.c b/lib/std/core/core-inline.c index a305ccd12..0733ba061 100644 --- a/lib/std/core/core-inline.c +++ b/lib/std/core/core-inline.c @@ -124,14 +124,16 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { } static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, const uint8_t** sstart, const uint8_t** send, kk_context_t* ctx) { - kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(sslice.str,&slen,ctx); - *start = s + sslice.start; - *end = s + sslice.start + sslice.len; + kk_ssize_t strlen; + const uint8_t* s = kk_string_buf_borrow(sslice.str,&strlen,ctx); + kk_ssize_t slstart = kk_integer_clamp_ssize_t_borrow(sslice.start,ctx); + kk_ssize_t sllen = kk_integer_clamp_ssize_t_borrow(sslice.len,ctx); + *start = s + slstart; + *end = s + slstart + sllen; if (sstart != NULL) *sstart = s; - if (send != NULL) *send = s + slen; + if (send != NULL) *send = s + strlen; kk_assert_internal(*start >= s && *start <= *end); - kk_assert_internal(*end >= *start && *end <= s + slen); + kk_assert_internal(*end >= *start && *end <= s + strlen); } static inline void kk_sslice_start_end_borrow( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, kk_context_t* ctx) { @@ -158,13 +160,14 @@ kk_string_t kk_slice_to_string( kk_std_core__sslice sslice, kk_context_t* ctx ) const uint8_t* end; kk_sslice_start_end_borrow(sslice, &start, &end, ctx); // is it the full string? - if (sslice.start == 0 && sslice.len == kk_string_len_borrow(sslice.str,ctx)) { + if (kk_integer_is_zero_borrow(sslice.start) && + kk_integer_eq_borrow(sslice.len,kk_integer_from_ssize_t(kk_string_len_borrow(sslice.str,ctx),ctx),ctx)) { // TODO: drop sslice and dup sslice.str? return sslice.str; } else { // if not, we copy len bytes - kk_string_t s = kk_string_alloc_dupn_valid_utf8(sslice.len, start, ctx); + kk_string_t s = kk_string_alloc_dupn_valid_utf8(kk_integer_clamp_ssize_t_borrow(sslice.len,ctx), start, ctx); kk_std_core__sslice_drop(sslice,ctx); return s; } @@ -174,7 +177,7 @@ kk_std_core__sslice kk_slice_first( kk_string_t str, kk_context_t* ctx ) { kk_ssize_t slen; const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* next = (slen > 0 ? kk_utf8_next(s) : s); - return kk_std_core__new_Sslice(str, 0, (next - s), ctx); + return kk_std_core__new_Sslice(str, kk_integer_zero, kk_integer_from_ptrdiff_t(next - s,ctx), ctx); } kk_std_core__sslice kk_slice_last( kk_string_t str, kk_context_t* ctx ) { @@ -182,7 +185,7 @@ kk_std_core__sslice kk_slice_last( kk_string_t str, kk_context_t* ctx ) { const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* end = s + slen; const uint8_t* prev = (s==end ? s : kk_utf8_prev(end)); - return kk_std_core__new_Sslice(str, (prev - s), (end - prev), ctx); + return kk_std_core__new_Sslice(str, kk_integer_from_ptrdiff_t(prev - s,ctx), kk_integer_from_ptrdiff_t(end - prev,ctx), ctx); } kk_std_core__sslice kk_slice_between( struct kk_std_core_Sslice slice1, struct kk_std_core_Sslice slice2, kk_context_t* ctx ) { @@ -190,15 +193,24 @@ kk_std_core__sslice kk_slice_between( struct kk_std_core_Sslice slice1, struct k const uint8_t* s2 = kk_string_buf_borrow( slice2.str, NULL, ctx ); if (s1 != s2) { kk_info_message("between: not equal slices: %p vs. %p\n", s1, s2); - return kk_std_core__new_Sslice(kk_string_empty(), 0, -1, ctx); // invalid slice + return kk_std_core__new_Sslice(kk_string_empty(), kk_integer_zero, kk_integer_min_one, ctx); // invalid slice + } + + kk_integer_t start; + kk_integer_t len; + if (kk_integer_lte_borrow(slice1.start,slice2.start,ctx)) { + start = kk_integer_dup(slice1.start,ctx); + len = kk_integer_sub(kk_integer_dup(slice2.start,ctx),kk_integer_dup(slice1.start,ctx),ctx); } - kk_ssize_t start = (slice1.start <= slice2.start ? slice1.start : slice2.start); - kk_ssize_t len = (slice1.start <= slice2.start ? slice2.start - slice1.start : slice1.start - slice2.start); + else { + start = kk_integer_dup(slice2.start,ctx); + len = kk_integer_sub(kk_integer_dup(slice1.start,ctx),kk_integer_dup(slice2.start,ctx),ctx); + } return kk_std_core__new_Sslice(slice1.str, start, len, ctx); } kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_context_t* ctx ) { - if (slice.len <= 0) { + if (!kk_integer_is_pos_borrow(slice.len,ctx)) { kk_std_core__sslice_drop(slice,ctx); return kk_std_core_types__new_Nothing(ctx); } @@ -207,18 +219,21 @@ kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_cont kk_sslice_start_end_borrow(slice, &start, &end, ctx); kk_ssize_t clen; const kk_char_t c = kk_utf8_read(start,&clen); - kk_assert_internal(clen > 0 && clen <= slice.len); - if (clen > slice.len) clen = slice.len; + kk_assert_internal(clen > 0 && clen <= kk_integer_clamp_ssize_t_borrow(slice.len,ctx)); + kk_integer_t iclen = kk_integer_min(kk_integer_from_ssize_t(clen,ctx),kk_integer_dup(slice.len,ctx),ctx); // TODO: specialize type to avoid boxing - kk_std_core__sslice snext = kk_std_core__new_Sslice(slice.str, slice.start + clen, slice.len - clen, ctx); + // note: don't drop slice as we take over all fields + kk_integer_t istart = kk_integer_add(slice.start,kk_integer_dup(iclen,ctx),ctx); + kk_integer_t ilen = kk_integer_sub(slice.len,iclen,ctx); + kk_std_core__sslice snext = kk_std_core__new_Sslice(slice.str, istart, ilen, ctx); kk_std_core_types__tuple2_ res = kk_std_core_types__new_dash__lp__comma__rp_( kk_char_box(c,ctx), kk_std_core__sslice_box(snext,ctx), ctx); return kk_std_core_types__new_Just( kk_std_core_types__tuple2__box(res,ctx), ctx ); } /* Borrow count */ struct kk_std_core_Sslice kk_slice_extend_borrow( struct kk_std_core_Sslice slice, kk_integer_t count, kk_context_t* ctx ) { - kk_ssize_t cnt = kk_integer_clamp_borrow(count,ctx); - if (cnt==0 || (slice.len <= 0 && cnt<0)) return slice; + kk_ssize_t cnt = kk_integer_clamp_ssize_t_borrow(count,ctx); + if (cnt==0 || (!kk_integer_is_pos_borrow(slice.len,ctx) && cnt<0)) return slice; const uint8_t* s0; const uint8_t* s1; kk_sslice_start_end_borrow(slice,&s0,&s1,ctx); @@ -230,21 +245,22 @@ struct kk_std_core_Sslice kk_slice_extend_borrow( struct kk_std_core_Sslice slic } while (cnt > 0 && *t != 0); } else { // cnt < 0 - const uint8_t* sstart = s0 - slice.start; + const uint8_t* sstart = s0 - kk_integer_clamp_ssize_t_borrow(slice.start,ctx); do { t = kk_utf8_prev(t); cnt++; } while (cnt < 0 && t > sstart); } if (t == s1) return slice; // length is unchanged - return kk_std_core__new_Sslice(slice.str, slice.start, (t < s0 ? 0 : (t - s0)), ctx); + kk_integer_drop(slice.len,ctx); + return kk_std_core__new_Sslice(slice.str, slice.start, kk_integer_from_ptrdiff_t(t < s0 ? 0 : (t - s0),ctx), ctx); } /* Borrow count */ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice slice, kk_integer_t count, kk_context_t* ctx ) { - const kk_ssize_t cnt0 = kk_integer_clamp_borrow(count,ctx); + const kk_ssize_t cnt0 = kk_integer_clamp_ssize_t_borrow(count,ctx); kk_ssize_t cnt = cnt0; - if (cnt==0 || (slice.start == 0 && cnt<0)) return slice; + if (cnt==0 || (kk_integer_is_zero_borrow(slice.start) && cnt<0)) return slice; const uint8_t* sstart; const uint8_t* s0; const uint8_t* s1; @@ -282,7 +298,10 @@ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice sli } // t1 points to the new end kk_assert_internal(t1 >= t0); - return kk_std_core__new_Sslice(slice.str, (t0 - sstart), (t1 - t0), ctx); + kk_integer_drop(slice.start,ctx); + kk_integer_drop(slice.len,ctx); + return kk_std_core__new_Sslice(slice.str, kk_integer_from_ptrdiff_t(t0 - sstart,ctx), + kk_integer_from_ptrdiff_t(t1 - t0,ctx), ctx); } /* Borrow iupto */ @@ -295,7 +314,7 @@ struct kk_std_core_Sslice kk_slice_common_prefix_borrow( kk_string_t str1, kk_st if (*s1 != *s2) break; } kk_string_drop(str2,ctx); - return kk_std_core__new_Sslice(str1, 0, count, ctx); + return kk_std_core__new_Sslice(str1, kk_integer_zero, kk_integer_from_ssize_t(count,ctx), ctx); } diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index 2b7c95a5d..c1a63e060 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -66,7 +66,7 @@ static void kk_regex_free( void* pre, kk_block_t* b, kk_context_t* ctx ) { kk_unused(ctx); pcre2_code* re = (pcre2_code*)pre; //kk_info_message( "free regex at %p\n", re ); - if (re != NULL) pcre2_code_free(re); + if (re != NULL) { pcre2_code_free(re); } } #define KK_REGEX_OPTIONS (PCRE2_ALT_BSUX | PCRE2_EXTRA_ALT_BSUX | PCRE2_MATCH_UNSET_BACKREF /* javascript compat */ \ @@ -119,7 +119,7 @@ static kk_std_core__list kk_regex_exec_ex( pcre2_code* re, pcre2_match_data* mat kk_ssize_t sstart = groups[i*2]; // on no-match, sstart and send == -1. kk_ssize_t send = groups[i*2 + 1]; kk_assert(send >= sstart); - kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow,ctx), sstart, send - sstart, ctx ); + kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow,ctx), kk_integer_from_ssize_t(sstart,ctx), kk_integer_from_ssize_t(send - sstart,ctx), ctx ); hd = kk_std_core__new_Cons(kk_reuse_null,kk_std_core__sslice_box(sslice,ctx), hd, ctx); if (i == 0) { if (mstart != NULL) { *mstart = sstart; } @@ -183,7 +183,7 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (rc > 0) { // found a match; // push string up to match, and the actual matched regex - kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str,ctx), start, mstart - start, ctx ); + kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(start,ctx), kk_integer_from_ssize_t(mstart - start,ctx), ctx ); kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(prelist,ctx), capcons, ctx ); @@ -204,7 +204,7 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss } // push final string part as well and end the list - kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str,ctx), next, len - next, ctx ); + kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(next,ctx), kk_integer_from_ssize_t(len - next,ctx), ctx ); kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); if (tail==NULL) res = cons; diff --git a/test/Spec.hs b/test/Spec.hs index 29dcd7a01..1997e933b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -26,9 +26,9 @@ data Mode = Test | New | Update deriving (Eq, Ord, Show) -data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, js :: Bool, par :: Bool } +data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, target :: String, par :: Bool } -optionsDefault = Options Test False False 0 False True +optionsDefault = Options Test False False 0 "" True data Cfg = Cfg{ flags :: [String], options :: Options, @@ -71,7 +71,7 @@ extendCfg (Cfg flags1 opts1 exclude1 fexclude1) (Cfg flags2 opts2 exclude2 fexcl initialCfg :: Options -> Cfg initialCfg options - = makeCfg (commonFlags ++ if (js options) then ["--target=js"] else []) + = makeCfg (commonFlags ++ if (not (null (target options))) then ["--target=" ++ target options] else []) options [] @@ -191,7 +191,9 @@ processOptions arg (options,hargs) else if (arg == "--system-ghc") then (options{sysghc=True}, hargs) else if (arg == "--target-js") - then (options{js=True}, hargs) + then (options{target="js"}, hargs) + else if (arg == "--target-c64c") + then (options{target="c64c"}, hargs) else if (arg == "--seq") then (options{par=False}, hargs) else (options, arg : hargs) @@ -220,7 +222,7 @@ main = do let cfg = initialCfg options runKoka cfg "" "util/link-test.kk" putStrLn "ok." - let spec = (if (js options || not (par options)) then id else parallel) $ + let spec = (if (target options == "js" || not (par options)) then id else parallel) $ discoverTests cfg (pwd "test") summary <- withArgs [] (runSpec spec hcfg{configFormatter=Just specProgress}) evaluateSummary summary diff --git a/test/parc/parc2.kk.out b/test/parc/parc2.kk.out index 8d037cd36..1bd0122d0 100644 --- a/test/parc/parc2.kk.out +++ b/test/parc/parc2.kk.out @@ -7,6 +7,6 @@ pub fun test : forall (x : list) -> list (std/core/Nil() : (list) ) -> x; _ - -> std/core/.unroll17012-append((std/core/types/.dup(x)), x); + -> std/core/.unroll17080-append((std/core/types/.dup(x)), x); }; }; \ No newline at end of file diff --git a/test/readme.md b/test/readme.md index f38801f75..a5bafb437 100644 --- a/test/readme.md +++ b/test/readme.md @@ -36,6 +36,7 @@ Options: --cabal # Use cabal to run koka. --system-ghc # If using stack, use --system-ghc option. --target-js # Test javascript backend +--target-c64c # Test compressed heap -O2 # Use optimization -O-1 # Full debug mode with internal runtime assertions enabled --seq # Test sequentially (instead of in parallel) From a10d8974de2da7d06a9fb9e1026086f62c3ffc57 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 1 Jan 2023 18:13:53 -0800 Subject: [PATCH 111/233] update ide to vs2022 --- .gitignore | 3 + kklib/ide/vs2022/kklib-test-effbayes.vcxproj | 199 ++++++++++++++ .../kklib-test-effbayes.vcxproj.filters | 36 +++ .../ide/vs2022/kklib-test-interactive.vcxproj | 182 +++++++++++++ .../kklib-test-interactive.vcxproj.filters | 16 ++ kklib/ide/vs2022/kklib-test.vcxproj | 172 ++++++++++++ kklib/ide/vs2022/kklib-test.vcxproj.filters | 21 ++ kklib/ide/vs2022/kklib.natvis | 140 ++++++++++ kklib/ide/vs2022/kklib.sln | 58 ++++ kklib/ide/vs2022/kklib.vcxproj | 250 ++++++++++++++++++ kklib/ide/vs2022/kklib.vcxproj.filters | 108 ++++++++ 11 files changed, 1185 insertions(+) create mode 100644 kklib/ide/vs2022/kklib-test-effbayes.vcxproj create mode 100644 kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters create mode 100644 kklib/ide/vs2022/kklib-test-interactive.vcxproj create mode 100644 kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters create mode 100644 kklib/ide/vs2022/kklib-test.vcxproj create mode 100644 kklib/ide/vs2022/kklib-test.vcxproj.filters create mode 100644 kklib/ide/vs2022/kklib.natvis create mode 100644 kklib/ide/vs2022/kklib.sln create mode 100644 kklib/ide/vs2022/kklib.vcxproj create mode 100644 kklib/ide/vs2022/kklib.vcxproj.filters diff --git a/.gitignore b/.gitignore index 6ff753a67..96efdba0c 100644 --- a/.gitignore +++ b/.gitignore @@ -18,6 +18,9 @@ package-lock.json test.kk *.pdb *.pdn +*.vcxproj.user +*.vcxproj.interactive +*. *~ *.exe *.vsix diff --git a/kklib/ide/vs2022/kklib-test-effbayes.vcxproj b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj new file mode 100644 index 000000000..73397df91 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj @@ -0,0 +1,199 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF78591-750E-4C21-A04D-22707CC66878} + kklibtesti + 10.0 + kklib-test-effbayes + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + false + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + Strict + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + _MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + CompileAsCpp + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + true + Strict + CompileAsCpp + + + true + true + Console + UseFastLinkTimeCodeGeneration + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters new file mode 100644 index 000000000..9308566b8 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj new file mode 100644 index 000000000..72d3cb3d5 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -0,0 +1,182 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF78590-750E-4C21-A04D-22707CC66878} + kklibtesti + 10.0 + kklib-test-interactive + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + true + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + Strict + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions) + stdcpp17 + CompileAsCpp + false + false + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + true + Strict + CompileAsCpp + + + true + true + Console + UseFastLinkTimeCodeGeneration + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters new file mode 100644 index 000000000..799c30196 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test.vcxproj b/kklib/ide/vs2022/kklib-test.vcxproj new file mode 100644 index 000000000..611e669a1 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test.vcxproj @@ -0,0 +1,172 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF7858F-750E-4C21-A04D-22707CC66878} + kklibtest + 10.0 + kklib-test + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + KK_STATIC_LIB=1;KK_MIMALLOC=1; + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + _MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + CompileAsCpp + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + false + CompileAsCpp + + + true + true + Console + + + + + AssemblyAndSourceCode + AssemblyAndSourceCode + + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test.vcxproj.filters b/kklib/ide/vs2022/kklib-test.vcxproj.filters new file mode 100644 index 000000000..9af54515c --- /dev/null +++ b/kklib/ide/vs2022/kklib-test.vcxproj.filters @@ -0,0 +1,21 @@ + + + + + {cfad405d-6bd1-44d5-9731-40fc308f3cfd} + + + + + Source Files + + + Source Files + + + + + Source Files + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib.natvis b/kklib/ide/vs2022/kklib.natvis new file mode 100644 index 000000000..1e65cd8cd --- /dev/null +++ b/kklib/ide/vs2022/kklib.natvis @@ -0,0 +1,140 @@ + + + + bigint, rc={((kk_bigint_s*)ibox)->_block.header.refcount} + small int= {((intptr_t)ibox)/4} + + ((kk_bigint_s*)ibox) + + + + + + + + + + + diff --git a/kklib/ide/vs2022/kklib.sln b/kklib/ide/vs2022/kklib.sln new file mode 100644 index 000000000..e6d506e69 --- /dev/null +++ b/kklib/ide/vs2022/kklib.sln @@ -0,0 +1,58 @@ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Version 16 +VisualStudioVersion = 16.0.30204.135 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib", "kklib.vcxproj", "{ABB5EAE7-B3E6-432E-B636-333449892EA6}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test", "kklib-test.vcxproj", "{FEF7858F-750E-4C21-A04D-22707CC66878}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test-interactive", "kklib-test-interactive.vcxproj", "{FEF78590-750E-4C21-A04D-22707CC66878}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test-effbayes", "kklib-test-effbayes.vcxproj", "{FEF78591-750E-4C21-A04D-22707CC66878}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|x64 = Debug|x64 + Debug|x86 = Debug|x86 + Release|x64 = Release|x64 + Release|x86 = Release|x86 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x64.ActiveCfg = Debug|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x64.Build.0 = Debug|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x86.ActiveCfg = Debug|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x86.Build.0 = Debug|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x64.ActiveCfg = Release|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x64.Build.0 = Release|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x86.ActiveCfg = Release|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x86.Build.0 = Release|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x64.Build.0 = Debug|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x64.Build.0 = Release|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x64.Build.0 = Debug|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x64.Build.0 = Release|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {4297F93D-486A-4243-995F-7D32F59AE82A} + EndGlobalSection +EndGlobal diff --git a/kklib/ide/vs2022/kklib.vcxproj b/kklib/ide/vs2022/kklib.vcxproj new file mode 100644 index 000000000..1006e9062 --- /dev/null +++ b/kklib/ide/vs2022/kklib.vcxproj @@ -0,0 +1,250 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {ABB5EAE7-B3E6-432E-B636-333449892EA6} + kklib + 10.0 + kklib + + + + StaticLibrary + true + v143 + + + StaticLibrary + false + v143 + true + + + StaticLibrary + true + v143 + + + StaticLibrary + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + + Level4 + Disabled + true + true + ../../include;../../mimalloc/include + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + CompileAsCpp + false + stdcpp17 + ProgramDatabase + + + + + + + + + + + Level4 + Disabled + true + true + ../../include;../../mimalloc/include + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + true + stdcpp17 + EditAndContinue + CompileAsCpp + Strict + + + + + + + + + + + + + + + + + + + Level4 + MaxSpeed + true + true + ../../include;../../mimalloc/include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;%(PreprocessorDefinitions);NDEBUG + AssemblyAndSourceCode + $(IntDir) + true + false + Default + CompileAsCpp + true + stdcpp17 + + + true + true + + + + + + + + + + + Level4 + MaxSpeed + true + true + ../../include;../../mimalloc/include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;%(PreprocessorDefinitions);NDEBUG + AssemblyAndSourceCode + $(IntDir) + true + false + Default + true + stdcpp17 + CompileAsCpp + Strict + + + true + true + + + + + + + + + + + + + + + + + + Level3 + Level3 + + + + + + + + + + AssemblyAndSourceCode + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib.vcxproj.filters b/kklib/ide/vs2022/kklib.vcxproj.filters new file mode 100644 index 000000000..a7df4aa39 --- /dev/null +++ b/kklib/ide/vs2022/kklib.vcxproj.filters @@ -0,0 +1,108 @@ + + + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + + + {2b556b10-f559-4b2d-896e-142652adbf0c} + + + {852a14ae-6dde-4e95-8077-ca705e97e5af} + + + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + + + + \ No newline at end of file From df10e663875c8b0d44c46e160aace497571867cc Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 3 Jan 2023 18:01:10 -0800 Subject: [PATCH 112/233] add kk_addr_t; improve ptr encode/decode --- kklib/include/kklib.h | 89 ++++++++++++-------------- kklib/include/kklib/atomic.h | 2 +- kklib/include/kklib/integer.h | 4 +- kklib/include/kklib/platform.h | 111 ++++++++++++++++++++++----------- kklib/src/init.c | 10 ++- 5 files changed, 125 insertions(+), 91 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 23143e742..c61f1dc21 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 99 // modify on changes to trigger recompilation +#define KKLIB_BUILD 100 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -407,8 +407,8 @@ typedef struct kk_yield_s { typedef struct kk_context_s { int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? - const intptr_t heap_mid; // mid point of the reserved heap address space (or 0 if the heap is not compressed) - const void* heap_start; // bottom of the heap (or NULL if the heap is not compressed) + const kk_addr_t heap_mid; // mid point of the reserved heap address space (or 0 if the heap is not compressed) + const void* heap_start; // start of the heap space (or NULL if the heap is not compressed) kk_datatype_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector kk_yield_t yield; // inlined yield structure (for efficiency) int32_t marker_unique; // unique marker generation @@ -898,67 +898,56 @@ static inline bool kk_is_value(kk_intb_t i) { // Without compression, pointer encode/decode is an identity operation. static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); + kk_addr_t a; #if KK_COMPRESS #if KK_CHERI - // arm CHERI for 32-bit or 64-bit kk_intb_t; all pointers are relative to the heap - kk_assert_internal(__builtin_cheri_base_get(p) == __builtin_cheri_address_get(ctx->heap_base)); kk_unused_internal(ctx); - size_t ofs = __builtin_cheri_offset_get(p); - #if KK_BOX_PTR_SHIFT > 0 - ofs = (ofs >> KK_BOX_PTR_SHIFT); - #endif - kk_assert_internal(ofs <= KK_UINTB_MAX); - kk_intb_t i = (kk_intb_t)ofs; - #elif (KK_INTB_SIZE==4) - // compress to 32-bit offsets, ctx->heap_mid contains the mid-point in the heap so we can do signed extension - intptr_t i = (intptr_t)p - ctx->heap_mid; - #if KK_BOX_PTR_SHIFT > 0 - i = kk_sarp(i, KK_BOX_PTR_SHIFT); - #endif - #elif (KK_INTB_SIZE==8) - // 128-bit system with 64-bit pointers; we only need to assume that our heap is located in the lower 2^63 adress space - kk_unused(ctx) - intptr_t i = (intptr_t)p; + a = (kk_addr_t)__builtin_cheri_address_get(p); #else - #error "define pointer compression for this platform" + a = (kk_addr_t)p; #endif -#else // |kk_intb_t| == |intptr_t| + #if (KK_INTB_SIZE==4) + // compress to 32-bit offsets, ctx->heap_mid contains the mid-point in the heap so we can do signed extension + a = a - ctx->heap_mid; + #else + // for 64- or 128-bit we use the address as is (and for 128 bit we assume we locate our heap in the lower 2^63-1 address space) + kk_unused(ctx); + #endif + #if KK_BOX_PTR_SHIFT > 0 + kk_assert_internal((a & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); + a = kk_sara(a, KK_BOX_PTR_SHIFT); + #endif +#else // no compression: |kk_intptr_t| == |kk_addr_t| == |kk_intb_t| kk_unused(ctx); - intptr_t i = (intptr_t)p; + a = (kk_addr_t)p; #endif - kk_assert_internal(i >= KK_INTB_MIN && i <= KK_INTB_MAX); - kk_assert_internal((i & KK_TAG_MASK) == 0); - return ((kk_intb_t)i | KK_TAG_PTR); + kk_assert_internal(a >= KK_INTB_MIN && a <= KK_INTB_MAX); + kk_assert_internal((a & KK_TAG_MASK) == 0); + return ((kk_intb_t)a | KK_TAG_PTR); } static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { kk_assert_internal(kk_is_ptr(b)); - b = (b & ~KK_TAG_PTR); -#if KK_COMPRESS + kk_addr_t a = b; // may sign-extend +#if (KK_TAG_PTR != 0) + a = (a & ~KK_TAG_MASK); +#endif +#if KK_COMPRESS + #if (KK_BOX_PTR_SHIFT > 0) + a = kk_shla(a, KK_BOX_PTR_SHIFT); + #endif + #if (KK_INTB_SIZE == 4) + a = a + ctx->heap_mid; + #else + kk_unused(ctx); + #endif #if KK_CHERI - // arm CHERI for 32-bit or 64-bit kk_intb_t; all pointers are relative to the heap base - size_t ofs = (size_t)b; - #if (KK_BOX_PTR_SHIFT > 0) - ofs = (ofs << KK_BOX_PTR_SHIFT); - #endif - return (kk_ptr_t)__builtin_cheri_offset_set(ctx->heap_base, ofs); - #elif (KK_INTB_SIZE == 4) - // decompress from 32-bit offsets - intptr_t i = b; // b sign-extends - #if (KK_BOX_PTR_SHIFT > 0) - kk_assert_internal((i & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); - i = kk_shlp(i, KK_BOX_PTR_SHIFT); - #endif - return (kk_ptr_t)(i + ctx->heap_mid); - #elif (KK_INTB_SIZE==8) - // 128-bit system with 64-bit compressed pointers; we only need to assume that our heap is located in the first 2^63 addresses. - kk_unused(ctx); - return (kk_ptr_t)((intptr_t)b); // ensure b sign-extends + return (kk_ptr_t)__builtin_cheri_address_set(ctx->heap_start, (vaddr_t)a); #else - #error "define pointer decompression for this platform" + return (kk_ptr_t)a; #endif -#else // |kk_intb_t| == |intptr_t| +#else // no compression: |kk_intb_t| == |kk_addr_t| == |intptr_t| kk_unused(ctx); - return (kk_ptr_t)b; + return (kk_ptr_t)a; #endif } diff --git a/kklib/include/kklib/atomic.h b/kklib/include/kklib/atomic.h index bd145e7fb..c93bc987b 100644 --- a/kklib/include/kklib/atomic.h +++ b/kklib/include/kklib/atomic.h @@ -26,7 +26,7 @@ #endif // ATOMIC_VAR_INIT is deprecated in C17 and C++20 -#if (__cplusplus >= 201803L || __STDC_VERSION__ >= 201710L) +#if (defined(KK_C17) || defined(KK_CPP20) || (__cplusplus >= 201803L)) #define KK_ATOMIC_VAR_INIT(x) x #else #define KK_ATOMIC_VAR_INIT(x) ATOMIC_VAR_INIT(x) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 1163391dd..fc5ef5b7b 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -464,7 +464,9 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: -----------------------------------------------------------------------------------*/ static kk_intf_t _kk_integer_value(kk_integer_t i) { - kk_assert_internal(kk_is_smallint(i)); + #if KK_INT_ARITHMETIC != KK_INT_USE_SOFA + kk_assert_internal(kk_is_smallint(i)); + #endif return (kk_intf_t)i.ibox; } diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 4eb03c083..28f24ed30 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -75,7 +75,7 @@ x86 16-bit large 32 16 16 32 16 intptr_t/long > size_t x86 16-bit huge 32 32 16 32 16 size_t > intx_t - We use a signed `size_t` as `kk_ssize_t` (see comments below) + We use a signed `size_t` as `kk_ssize_t` (see earlier comments) We also have: - `kk_intb_t` (boxed integer) as the integer size that can hold a boxed value @@ -113,6 +113,9 @@ #endif #ifdef __STDC_VERSION__ +#if (__STDC_VERSION__ >= 201710L) +#define KK_C17 1 +#endif #if (__STDC_VERSION__ >= 201112L) #define KK_C11 1 #endif @@ -122,13 +125,13 @@ #endif #ifdef __cplusplus -#if (__cplusplus >= 202002L) +#if (__cplusplus >= 202002L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 202002L) #define KK_CPP20 1 #endif -#if (__cplusplus >= 201703L) +#if (__cplusplus >= 201703L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201703L) #define KK_CPP17 1 #endif -#if (__cplusplus >= 201402L) +#if (__cplusplus >= 201402L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201402L) #define KK_CPP14 1 #endif #if (__cplusplus >= 201103L) || (_MSC_VER > 1900) @@ -188,7 +191,7 @@ #define kk_struct_packed __pragma(pack(push,1)) struct #define kk_struct_packed_end __pragma(pack(pop)) #define KK_HAS_STRUCT_PACKING 1 -#ifndef __cplusplus +#ifndef __cplusplus // need c++ compilation for correct atomic operations on msvc #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif #else @@ -205,7 +208,7 @@ #if defined(__GNUC__) || defined(__clang__) #define kk_unlikely(x) (__builtin_expect(!!(x),false)) #define kk_likely(x) (__builtin_expect(!!(x),true)) -#elif (defined(__cplusplus) && (__cplusplus >= 202002L)) || (defined(_MSVC_LANG) && _MSVC_LANG >= 202002L) +#elif defined(KK_CPP20) #define kk_unlikely(x) (x) [[unlikely]] #define kk_likely(x) (x) [[likely]] #else @@ -239,11 +242,7 @@ #endif #endif -#define KK_KiB (1024) -#define KK_MiB (1024L*KK_KiB) -#define KK_GiB (1024L*KK_MiB) - -// Defining constants of a specific size +// Defining constants of a specific size (as not all platforms define the INTXX_C macros) #if LONG_MAX == INT64_MAX # define KK_LONG_SIZE 8 # define KK_I32(i) (i) @@ -251,7 +250,7 @@ # define KK_U32(i) (i##U) # define KK_U64(i) (i##UL) #elif LONG_MAX == INT32_MAX -# define KK_LONG_SIZE 4 +# define KK_LONG_SIZE 4 # define KK_I32(i) (i##L) # define KK_I64(i) (i##LL) # define KK_U32(i) (i##UL) @@ -260,35 +259,55 @@ #error size of a `long` must be 32 or 64 bits #endif +#ifdef _MSC_VER +# define KK_I128(i) (i##i128) +# define KK_U128(i) (i##ui128) +#else +# define KK_I128(i) (INT128_C(i)) +# define KK_U128(i) (UINT128_C(i)) +#endif + +#define KK_KiB (1024) +#define KK_MiB (KK_I32(1024)*KK_KiB) +#define KK_GiB (KK_I32(1024)*KK_MiB) + + // Define size of intptr_t -#if INTPTR_MAX == INT64_MAX -# define KK_INTPTR_SIZE 8 -# define KK_INTPTR_SHIFT 3 -# define KK_IP(i) KK_I64(i) -# define KK_UP(i) KK_U64(i) +#if INTPTR_MAX == INT128_MAX +# define KK_INTPTR_SIZE 16 +# define KK_INTPTR_SHIFT 4 +# define KK_IP(i) KK_I128(i) +# define KK_UP(i) KK_U128(i) +#elif INTPTR_MAX == INT64_MAX +# define KK_INTPTR_SIZE 8 +# define KK_INTPTR_SHIFT 3 +# define KK_IP(i) KK_I64(i) +# define KK_UP(i) KK_U64(i) #elif INTPTR_MAX == INT32_MAX -# define KK_INTPTR_SIZE 4 -# define KK_INTPTR_SHIFT 2 -# define KK_IP(i) KK_I32(i) -# define KK_UP(i) KK_U32(i) +# define KK_INTPTR_SIZE 4 +# define KK_INTPTR_SHIFT 2 +# define KK_IP(i) KK_I32(i) +# define KK_UP(i) KK_U32(i) #elif INTPTR_MAX == INT16_MAX -# define KK_INTPTR_SIZE 2 -# define KK_INTPTR_SHIFT 1 -# define KK_IP(i) i -# define KK_UP(i) i -#elif INTPTR_MAX > INT64_MAX // assume 128-bit -# define KK_INTPTR_SIZE 16 -# define KK_INTPTR_SHIFT 4 -# define KK_IP(i) KK_I64(i) -# define KK_UP(i) KK_U64(i) +# define KK_INTPTR_SIZE 2 +# define KK_INTPTR_SHIFT 1 +# define KK_IP(i) i +# define KK_UP(i) i #else -#error platform addresses must be 16, 32, 64, or 128 bits +#error platform pointers must be 16, 32, 64, or 128 bits #endif #define KK_INTPTR_BITS (8*KK_INTPTR_SIZE) #define KK_INTPTR_ALIGNUP(x) ((((x)+KK_INTPTR_SIZE-1)/KK_INTPTR_SIZE)*KK_INTPTR_SIZE) // Define size of size_t and kk_ssize_t -#if SIZE_MAX == UINT64_MAX +#if SIZE_MAX == UINT128_MAX +# define KK_SIZE_SIZE 16 +# define KK_IZ(i) KK_I128(i) +# define KK_UZ(i) KK_U128(i) +# define KK_SSIZE_MAX INT64_MAX +# define KK_SSIZE_MIN INT64_MIN +typedef int64_t kk_ssize_t; +#elif SIZE_MAX == UINT64_MAX # define KK_SIZE_SIZE 8 # define KK_IZ(i) KK_I64(i) # define KK_UZ(i) KK_U64(i) @@ -310,13 +329,13 @@ typedef int32_t kk_ssize_t; # define KK_SSIZE_MIN INT16_MIN typedef int16_t kk_ssize_t; #else -#error size of a `size_t` must be 16, 32 or 64 bits +#error size of a `size_t` must be 16, 32, 64 or 128 bits #endif -#define KK_SSIZE_SIZE KK_SIZE_SIZE -#define KK_SIZE_BITS (8*KK_SIZE_SIZE) +#define KK_SSIZE_SIZE KK_SIZE_SIZE +#define KK_SIZE_BITS (8*KK_SIZE_SIZE) -// off_t: we use 64-bit file offsets (unless on a 16-bit platform) +// off_t: we use signed 64-bit file offsets (unless on a 16-bit platform) #if (INT_MAX > INT16_MAX) typedef int64_t kk_off_t; #define KK_OFF_MAX INT64_MAX @@ -327,6 +346,22 @@ typedef int32_t kk_off_t; #define KK_OFF_MIN INT32_MIN #endif +// kk_addr_t: a signed integer that can hold a plain address (usually intptr_t but may be smaller on capability architectures) +#if defined(KK_CHERI) +typedef kk_ssize_t kk_addr_t; +typedef kk_size_t kk_uaddr_t; +#define KK_ADDR_MAX KK_SSIZE_MAX +#define KK_ADDR_MIN KK_SSIZE_MIN +#define KK_ADDR_BITS KK_SIZE_BITS +#else +typedef intptr_t kk_addr_t; +typedef uintptr_t kk_uaddr_t; +#define KK_ADDR_MAX INTPTR_MAX +#define KK_ADDR_MIN INTPTR_MIN +#define KK_ADDR_BITS KK_INTPTR_BITS +#endif + + // We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` bytes. static inline kk_ssize_t kk_to_ssize_t(size_t sz) { kk_assert(sz <= KK_SSIZE_MAX); @@ -440,7 +475,7 @@ typedef uint32_t kk_uintb_t; #error "pointer compression can only be used with C compilers that support struct packing" #endif -// Largest natural integer that fits into a boxed value +// A "field" integer is the largest natural integer that fits into a boxed value #if (KK_INTB_SIZE > KK_INTX_SIZE) // ensure it fits the natural register size typedef kk_intx_t kk_intf_t; typedef kk_uintx_t kk_uintf_t; @@ -470,6 +505,7 @@ static inline kk_uintx_t kk_shr(kk_uintx_t u, int shift) { return (u >> (sh static inline kk_intf_t kk_sarf(kk_intf_t i, int shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } static inline kk_uintf_t kk_shrf(kk_uintf_t u, int shift) { return (u >> (shift & (KK_INTF_BITS - 1))); } static inline kk_intb_t kk_sarb(kk_intb_t i, int shift) { return (i >> (shift & (KK_INTB_BITS - 1))); } +static inline kk_addr_t kk_sara(kk_addr_t i, int shift) { return (i >> (shift & (KK_ADDR_BITS - 1))); } static inline uintptr_t kk_shrp(uintptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } static inline intptr_t kk_sarp(intptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } @@ -482,6 +518,7 @@ static inline uint64_t kk_shr64(uint64_t u, int64_t shift) { return (u >> (sh static inline kk_intx_t kk_shl(kk_intx_t i, int shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } static inline kk_intf_t kk_shlf(kk_intf_t i, int shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } static inline kk_intb_t kk_shlb(kk_intb_t i, int shift) { return (kk_intb_t)((kk_uintb_t)i << (shift & (KK_INTB_BITS - 1))); } +static inline kk_addr_t kk_shla(kk_addr_t i, int shift) { return (kk_addr_t)((kk_uaddr_t)i << (shift & (KK_ADDR_BITS - 1))); } static inline intptr_t kk_shlp(intptr_t i, int shift) { return (intptr_t)((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } static inline int32_t kk_shl32(int32_t i, int32_t shift) { return (int32_t)((uint32_t)i << (shift & 31)); } static inline int64_t kk_shl64(int64_t i, int64_t shift) { return (int64_t)((uint64_t)i << (shift & 63)); } diff --git a/kklib/src/init.c b/kklib/src/init.c index ec1d52bf8..80a3d6883 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -201,7 +201,7 @@ static void kklib_init(void) { #if KK_USE_MEM_ARENA #if (KK_INTB_SIZE==4) - const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTB_BITS + KK_BOX_PTR_SHIFT); + const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTB_BITS + KK_BOX_PTR_SHIFT); // 16GiB #elif KK_CHERI && (KK_INTB_SIZE==8) const kk_ssize_t heap_size = 128 * KK_GiB; // todo: parameterize? #else @@ -253,7 +253,13 @@ kk_context_t* kk_get_context(void) { ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); kk_assign_const(kk_heap_t,ctx->heap) = heap; kk_assign_const(void*, ctx->heap_start) = arena_start; - kk_assign_const(intptr_t, ctx->heap_mid) = (intptr_t)arena_start + (intptr_t)(arena_size / 2); + kk_addr_t arena_start_addr; + #if KK_CHERI + arena_start_addr = __builtin_cheri_address_get(arena_start); + #else + arena_start_addr = (kk_addr_t)arena_start; + #endif + kk_assign_const(kk_addr_t, ctx->heap_mid) = arena_start_addr + (kk_addr_t)(arena_size / 2); #elif defined(KK_MIMALLOC) mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); From b41a2c301c2ab002d693588d5b5d737a66bc20e9 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 4 Jan 2023 18:50:02 -0800 Subject: [PATCH 113/233] wip: late assign pattern bindings --- src/Backend/C/FromCore.hs | 84 +++++++++++++++++++++++---------------- 1 file changed, 50 insertions(+), 34 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 4e31796dc..000fd1104 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1403,6 +1403,8 @@ genExprStat result expr -- Match --------------------------------------------------------------------------------- +type Bindings = [(TName,Doc)] + -- | Generates a statement for a match expression regarding a given return context genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc genMatch result0 exprDocs branches @@ -1457,24 +1459,29 @@ genMatch result0 exprDocs branches genBranch :: Result -> [Doc] -> Bool -> Branch -> Asm Doc genBranch result exprDocs doTest branch@(Branch patterns guards) - = do doc <- genPattern doTest (freeLocals guards) (zip exprDocs patterns) (genGuards result guards) + = do doc <- genPattern doTest [] (zip exprDocs patterns) (genGuards result guards) if (doc `dstartsWith` "if") then return doc else return (block doc) -- for C++ we need to scope the locals or goto's can skip initialization -genGuards :: Result -> [Guard] -> Asm Doc -genGuards result guards - = do docs <- mapM (genGuard result) guards +genGuards :: Result -> [Guard] -> Bindings -> Asm Doc +genGuards result guards bindings + = do docs <- mapM (genGuard bindings result) guards return (vcat docs) -genGuard :: Result -> Guard-> Asm Doc -genGuard result (Guard guard expr) - = case guard of - Con tname repr | getName tname == nameTrue - -> genStat result expr - _ -> do (gddoc,gdoc) <- genExpr guard - sdoc <- genStat result expr - return (vcat gddoc <-> text "if" <+> parensIf gdoc <+> block (sdoc)) +genGuard :: Bindings -> Result -> Guard-> Asm Doc +genGuard bindings result (Guard guard expr) + = do let guardFree = freeLocals guard + exprFree = freeLocals expr + (bsGuard,bsOther) = partition (\(name,_) -> tnamesMember name guardFree) bindings + bsExpr = filter (\(name,_) -> tnamesMember name exprFree) bsOther + case guard of + Con tname repr | getName tname == nameTrue + -> do doc <- genStat result expr + return (vcat (map snd bsExpr ++ [doc])) + _ -> do (gddoc,gdoc) <- genExpr guard + sdoc <- genStat result expr + return (vcat $ map snd bsGuard ++ gddoc ++ [text "if" <+> parensIf gdoc <+> block (vcat (map snd bsExpr ++ [sdoc]))]) parensIf :: Doc -> Doc -- avoid parens if already parenthesized parensIf d @@ -1483,24 +1490,26 @@ parensIf d then d else parens d -genPattern :: Bool -> TNames -> [(Doc,Pattern)] -> Asm Doc -> Asm Doc -genPattern doTest gfree [] genBody - = genBody -genPattern doTest gfree dpatterns genBody - = do (testss,localss,nextPatternss) <- fmap (unzip3 . concat) $ - mapM (genPatternTest doTest gfree) dpatterns +genPattern :: Bool -> Bindings -> [(Doc,Pattern)] -> (Bindings -> Asm Doc) -> Asm Doc +genPattern doTest bindings [] genBody + = genBody bindings + +genPattern doTest bindings0 dpatterns genBody + = do (testss,localss,bindingss,nextPatternss) <- fmap (unzip4 . concat) $ + mapM (genPatternTest doTest) dpatterns let tests = concat testss locals = concat localss + bindings = bindings0 ++ concat bindingss nextPatterns = concat nextPatternss - ndoc <- genPattern doTest gfree nextPatterns genBody + ndoc <- genPattern doTest bindings nextPatterns genBody if (null tests) then return (vcat (locals ++ [ndoc])) else return (text "if" <+> parensIf (hcat (punctuate (text " && ") tests)) <+> block (vcat (locals ++ [ndoc]))) -genPatternTest :: Bool -> TNames -> (Doc,Pattern) -> Asm [([Doc],[Doc],[(Doc,Pattern)])] -genPatternTest doTest gfree (exprDoc,pattern) +genPatternTest :: Bool -> (Doc,Pattern) -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] +genPatternTest doTest (exprDoc,pattern) = let test xs = if doTest then xs else [] in case pattern of PatWild -> return [] @@ -1526,30 +1535,33 @@ genPatternTest doTest gfree (exprDoc,pattern) -- assign = [] -- unbox = genBoxCall "unbox" True {- borrowing -} targ exprDoc next = genNextPatterns (\self fld -> self) unbox targ [pattern] - return [([],assign,next)] + return [([],assign,[],next)] PatVar tname pattern - -> do let after = if (patternVarFree pattern && not (tnamesMember tname gfree)) then [] - else [ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi] + -> do let binding = ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi + eagerAssign = False + (assign,bindings) = if (patternVarFree pattern && not eagerAssign) + then ([],[(tname,binding)]) + else ([binding],[]) next = genNextPatterns (\self fld -> self) (ppDefName (getName tname)) (typeOf tname) [pattern] - return [([],after,next)] + return [([],assign,bindings,next)] PatLit (LitString s) - -> return [(test [text "kk_string_cmp_cstr_borrow" <.> arguments [exprDoc,fst (cstring s)] <+> text "== 0"],[],[])] + -> return [(test [text "kk_string_cmp_cstr_borrow" <.> arguments [exprDoc,fst (cstring s)] <+> text "== 0"],[],[],[])] PatLit lit@(LitInt _) - -> return [(test [text "kk_integer_eq_borrow" <.> arguments [exprDoc,ppLit lit]],[],[])] + -> return [(test [text "kk_integer_eq_borrow" <.> arguments [exprDoc,ppLit lit]],[],[],[])] PatLit lit - -> return [(test [exprDoc <+> text "==" <+> ppLit lit],[],[])] + -> return [(test [exprDoc <+> text "==" <+> ppLit lit],[],[],[])] PatCon tname patterns repr targs exists tres info skip -> -- trace ("patCon: " ++ show info ++ "," ++ show tname ++ ", " ++ show repr) $ case repr of ConEnum{} | conInfoName info == nameTrue - -> return [(xtest [exprDoc],[],[])] + -> return [(xtest [exprDoc],[],[],[])] ConEnum{} | conInfoName info == nameFalse - -> return [(xtest [text "!" <.> parens exprDoc],[],[])] + -> return [(xtest [text "!" <.> parens exprDoc],[],[],[])] ConAsJust{} -> do let next = genNextPatterns (\self fld -> text "kk_datatype_unJust" <.> arguments [self]) exprDoc (typeOf tname) patterns - return [(xtest [conTestName info <.> arguments [exprDoc]],[],next)] + return [(xtest [conTestName info <.> arguments [exprDoc]],[],[],next)] _ -> let dataRepr = conDataRepr repr in if (dataReprIsValue dataRepr || isConSingleton repr) then valTest tname info dataRepr @@ -1557,7 +1569,7 @@ genPatternTest doTest gfree (exprDoc,pattern) where xtest xs = if skip then [] else test xs - valTest :: TName -> ConInfo -> DataRepr -> Asm [([Doc],[Doc],[(Doc,Pattern)])] + valTest :: TName -> ConInfo -> DataRepr -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] valTest conName conInfo dataRepr = --do let next = genNextPatterns (exprDoc) (typeOf tname) patterns -- return [(test [conTestName conInfo <.> parens exprDoc],[assign],next)] @@ -1565,14 +1577,14 @@ genPatternTest doTest gfree (exprDoc,pattern) then "._cons." ++ show (ppDefName (getName conName)) ++ "." else "." next = genNextPatterns (\self fld -> self <.> text selectOp <.> fld) exprDoc (typeOf tname) patterns - return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[],next)] + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[],[],next)] conTest conInfo = do local <- newVarName "con" let next = genNextPatterns (\self fld -> self <.> text "->" <.> fld) (ppDefName local) (typeOf tname) patterns typeDoc = text "struct" <+> ppName (conInfoName conInfo) <.> text "*" assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> arguments [exprDoc] <.> semi - return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[assign],next)] + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[assign],[],next)] patternVarFree pat = case pat of @@ -2666,3 +2678,7 @@ resultType tp = case splitFunScheme tp of Just (_,_,_,_,resTp) -> resTp _ -> failure ("Backend.C.FromCore.resultType: not a function type: " ++ show (pretty tp)) + +unzip4 xs = unzipx4 [] [] [] [] xs +unzipx4 acc1 acc2 acc3 acc4 [] = (reverse acc1, reverse acc2, reverse acc3, reverse acc4) +unzipx4 acc1 acc2 acc3 acc4 ((x,y,z,zz):xs) = unzipx4 (x:acc1) (y:acc2) (z:acc3) (zz:acc4) xs From 620ff779ed8c87509ad0aa83579e8f3614b0c7a7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 5 Jan 2023 09:29:41 -0800 Subject: [PATCH 114/233] add --feagerpatbind as an option --- src/Backend/C/FromCore.hs | 60 +++++++++++++++++++-------------------- src/Compiler/Compile.hs | 2 +- src/Compiler/Options.hs | 3 ++ 3 files changed, 33 insertions(+), 32 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 000fd1104..8f6fa49d5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -66,9 +66,9 @@ externalNames -- Generate C code from System-F core language -------------------------------------------------------------------------- -cFromCore :: CTarget -> BuildType -> FilePath -> Pretty.Env -> Platform -> Newtypes -> Borrowed -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> Maybe (Name,Bool) -> Core -> (Doc,Doc,Core) -cFromCore ctarget buildType sourceDir penv0 platform newtypes borrowed uniq enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference stackSize mbMain core - = case runAsm uniq (Env moduleName moduleName False penv externalNames newtypes platform False) +cFromCore :: CTarget -> BuildType -> FilePath -> Pretty.Env -> Platform -> Newtypes -> Borrowed -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Maybe (Name,Bool) -> Core -> (Doc,Doc,Core) +cFromCore ctarget buildType sourceDir penv0 platform newtypes borrowed uniq enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference eagerPatBind stackSize mbMain core + = case runAsm uniq (Env moduleName moduleName False penv externalNames newtypes platform eagerPatBind) (genModule ctarget buildType sourceDir penv platform newtypes borrowed enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference stackSize mbMain core) of (bcore,cdoc,hdoc) -> (cdoc,hdoc,bcore) where @@ -385,8 +385,8 @@ genTopDefDecl genSig inlineC def@(Def name tp defBody vis sort inl rng comm) genFunDef params body = do let args = map ( ppName . getName ) params isTailCall = body `isTailCalling` name - bodyDoc <- (if isTailCall then withStatement else id) - (genStat (ResultReturn (Just (TName name resTp)) params) body) + bodyDoc <- -- (if isTailCall then withStatement else id) + genStat (ResultReturn (Just (TName name resTp)) params) body penv <- getPrettyEnv let tpDoc = typeComment (Pretty.ppType penv tp) let sig = genLamSig inlineC vis name params body @@ -1459,7 +1459,8 @@ genMatch result0 exprDocs branches genBranch :: Result -> [Doc] -> Bool -> Branch -> Asm Doc genBranch result exprDocs doTest branch@(Branch patterns guards) - = do doc <- genPattern doTest [] (zip exprDocs patterns) (genGuards result guards) + = do eagerPatBind <- getEagerPatBind + doc <- genPattern doTest eagerPatBind [] (zip exprDocs patterns) (genGuards result guards) if (doc `dstartsWith` "if") then return doc else return (block doc) -- for C++ we need to scope the locals or goto's can skip initialization @@ -1473,15 +1474,17 @@ genGuard :: Bindings -> Result -> Guard-> Asm Doc genGuard bindings result (Guard guard expr) = do let guardFree = freeLocals guard exprFree = freeLocals expr - (bsGuard,bsOther) = partition (\(name,_) -> tnamesMember name guardFree) bindings - bsExpr = filter (\(name,_) -> tnamesMember name exprFree) bsOther + (bindsGuard,bindsOther) = partition (\(name,_) -> tnamesMember name guardFree) bindings + guardLocals = map snd bindsGuard + exprLocals = map snd (filter (\(name,_) -> tnamesMember name exprFree) bindsOther) case guard of Con tname repr | getName tname == nameTrue -> do doc <- genStat result expr - return (vcat (map snd bsExpr ++ [doc])) + return (vcat (guardLocals ++ exprLocals ++ [doc])) _ -> do (gddoc,gdoc) <- genExpr guard sdoc <- genStat result expr - return (vcat $ map snd bsGuard ++ gddoc ++ [text "if" <+> parensIf gdoc <+> block (vcat (map snd bsExpr ++ [sdoc]))]) + return (vcat $ guardLocals ++ gddoc ++ [text "if" <+> parensIf gdoc <+> + block (vcat (exprLocals ++ [sdoc]))]) parensIf :: Doc -> Doc -- avoid parens if already parenthesized parensIf d @@ -1490,26 +1493,26 @@ parensIf d then d else parens d -genPattern :: Bool -> Bindings -> [(Doc,Pattern)] -> (Bindings -> Asm Doc) -> Asm Doc -genPattern doTest bindings [] genBody +genPattern :: Bool -> Bool -> Bindings -> [(Doc,Pattern)] -> (Bindings -> Asm Doc) -> Asm Doc +genPattern doTest eagerPatBind bindings [] genBody = genBody bindings -genPattern doTest bindings0 dpatterns genBody +genPattern doTest eagerPatBind bindings0 dpatterns genBody = do (testss,localss,bindingss,nextPatternss) <- fmap (unzip4 . concat) $ - mapM (genPatternTest doTest) dpatterns + mapM (genPatternTest doTest eagerPatBind) dpatterns let tests = concat testss locals = concat localss bindings = bindings0 ++ concat bindingss nextPatterns = concat nextPatternss - ndoc <- genPattern doTest bindings nextPatterns genBody + ndoc <- genPattern doTest eagerPatBind bindings nextPatterns genBody if (null tests) then return (vcat (locals ++ [ndoc])) else return (text "if" <+> parensIf (hcat (punctuate (text " && ") tests)) <+> block (vcat (locals ++ [ndoc]))) -genPatternTest :: Bool -> (Doc,Pattern) -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] -genPatternTest doTest (exprDoc,pattern) +genPatternTest :: Bool -> Bool -> (Doc,Pattern) -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] +genPatternTest doTest eagerPatBind (exprDoc,pattern) = let test xs = if doTest then xs else [] in case pattern of PatWild -> return [] @@ -1538,10 +1541,9 @@ genPatternTest doTest (exprDoc,pattern) return [([],assign,[],next)] PatVar tname pattern -> do let binding = ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi - eagerAssign = False - (assign,bindings) = if (patternVarFree pattern && not eagerAssign) - then ([],[(tname,binding)]) - else ([binding],[]) + (assign,bindings) = if (patternVarFree pattern && not eagerPatBind) + then ([],[(tname,binding)]) -- read field as late as possible (for nested pattern matches) + else ([binding],[]) -- read field right away next = genNextPatterns (\self fld -> self) (ppDefName (getName tname)) (typeOf tname) [pattern] return [([],assign,bindings,next)] PatLit (LitString s) @@ -2279,7 +2281,7 @@ data Env = Env { moduleName :: Name -- | current modul , substEnv :: [(TName, Doc)] -- | substituting names , newtypes :: Newtypes , platform :: Platform - , inStatement :: Bool -- | for generating correct function declarations in strict mode + , eagerPatBind :: Bool } data Result = ResultReturn (Maybe TName) [TName] -- first field carries function name if not anonymous and second the arguments which are always known @@ -2377,6 +2379,11 @@ getPrettyEnv = do env <- getEnv return (prettyEnv env) +getEagerPatBind :: Asm Bool +getEagerPatBind + = do env <- getEnv + return (eagerPatBind env) + withTypeVars :: [TypeVar] -> Asm a -> Asm a withTypeVars vars asm = withEnv (\env -> env{ prettyEnv = Pretty.niceEnv (prettyEnv env) vars }) asm @@ -2385,15 +2392,6 @@ withNameSubstitutions :: [(TName, Doc)] -> Asm a -> Asm a withNameSubstitutions subs asm = withEnv (\env -> env{ substEnv = subs ++ substEnv env }) asm -withStatement :: Asm a -> Asm a -withStatement asm - = withEnv (\env -> env{ inStatement = True }) asm - -getInStatement :: Asm Bool -getInStatement - = do env <- getEnv - return (inStatement env) - getNewtypes :: Asm Newtypes getNewtypes = do env <- getEnv diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 87de94327..ee1ee3ffe 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -1228,7 +1228,7 @@ codeGenC sourceFile newtypes borrowed0 unique0 term flags modules compileTarget _ -> CDefault (cdoc,hdoc,bcore) = cFromCore ctarget (buildType flags) sourceDir (prettyEnvFromFlags flags) (platform flags) newtypes borrowed0 unique0 (parcReuse flags) (parcSpecialize flags) (parcReuseSpec flags) - (parcBorrowInference flags) (stackSize flags) mbEntry core0 + (parcBorrowInference flags) (optEagerPatBind flags) (stackSize flags) mbEntry core0 bcoreDoc = Core.Pretty.prettyCore (prettyEnvFromFlags flags){ coreIface = False, coreShowDef = True } (C CDefault) [] bcore -- writeDocW 120 (outBase ++ ".c.kkc") bcoreDoc when (showFinalCore flags) $ diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index 369d0f580..e8a2e27fa 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -177,6 +177,7 @@ data Flags , optctail :: Bool , optctailCtxPath :: Bool , optUnroll :: Int + , optEagerPatBind :: Bool -- bind pattern fields as early as possible? , parcReuse :: Bool , parcSpecialize :: Bool , parcReuseSpec :: Bool @@ -271,6 +272,7 @@ flagsNull True -- optctail True -- optctailCtxPath (-1) -- optUnroll + False -- optEagerPatBind (read fields as late as possible) True -- parc reuse True -- parc specialize True -- parc reuse specialize @@ -382,6 +384,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , hide $ fflag ["trmcctx"] (\b f -> f{optctailCtxPath=b}) "enable trmc context paths" , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" , hide $ fflag ["unroll"] (\b f -> f{optUnroll=(if b then 1 else 0)}) "enable recursive definition unrolling" + , hide $ fflag ["eagerpatbind"] (\b f -> f{optEagerPatBind=b}) "load pattern fields as early as possible" -- deprecated , hide $ option [] ["cmake"] (ReqArg cmakeFlag "cmd") "use to invoke cmake" From 3b577413eef02b164e82e6d9c1ff3e88321a51b7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 5 Jan 2023 09:58:20 -0800 Subject: [PATCH 115/233] box function pointers as intf, fix tick monotonicity --- kklib/include/kklib.h | 4 ++-- kklib/include/kklib/box.h | 16 +++++++--------- kklib/src/time.c | 17 ++++++++++------- 3 files changed, 19 insertions(+), 18 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index c61f1dc21..7e486bd96 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 100 // modify on changes to trigger recompilation +#define KKLIB_BUILD 102 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -369,7 +369,7 @@ typedef int64_t kk_secs_t; typedef int64_t kk_asecs_t; typedef struct kk_duration_s { kk_secs_t seconds; - kk_asecs_t attoseconds; // always >= 0 + kk_asecs_t attoseconds; // always >= 0, use `kk_duration_norm` to normalize } kk_duration_t; diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 69cd83a82..c391751ff 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -393,28 +393,26 @@ typedef struct kk_cfunptr_s { } *kk_cfunptr_t; -// Koka function pointers -// Best is if we can assume these are always aligned but that is difficult to ensure with various compilers. -// Instead we assume the top bit of a function address is always clear so we can encode as 2*address + 1. -// If the heap is compressed, use the offset to the main function +// Koka function pointers. +// We encode these as values for efficiency. It would be best if we can assume functions addresses +// are always aligned but it turns out that this is difficult to ensure with various compilers. +// Instead we assume that the function adresses always fit an `kk_intf_t` and encode as a regular `kk_intf_t`. +// If the heap is compressed, use the offset to the main function. static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { // never drop; only used from function call kk_unused(ctx); intptr_t f = (intptr_t)fun; #if KK_COMPRESS f = f - (intptr_t)&kk_main_start; #endif - kk_assert(kk_shrp(f, KK_INTPTR_BITS - KK_TAG_BITS) == 0); // assume top bits of function pointer addresses are clear kk_assert(f >= KK_INTF_BOX_MIN(0) && f <= KK_INTF_BOX_MAX(0)); - kk_box_t b = { kk_intf_encode((kk_intf_t)f,0) }; // so we can encode as a value - return b; + return kk_intf_box((kk_intf_t)f); } #define kk_kkfun_ptr_box(fun,ctx) kk_kkfun_ptr_boxx((kk_cfun_ptr_t)fun, ctx) - static inline kk_cfun_ptr_t kk_kkfun_ptr_unbox(kk_box_t b, kk_context_t* ctx) { kk_unused(ctx); - intptr_t f = kk_intf_decode(b.box, 0); + intptr_t f = kk_intf_unbox(b); #if KK_COMPRESS f = f + (intptr_t)&kk_main_start; #endif diff --git a/kklib/src/time.c b/kklib/src/time.c index ae46b428e..07a25a3d5 100644 --- a/kklib/src/time.c +++ b/kklib/src/time.c @@ -97,7 +97,7 @@ static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { int64_t frac = t.QuadPart % ctx->timer_freq; int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; d.attoseconds = frac * resolution; - return d; + return kk_duration_norm(d); } #else @@ -126,7 +126,7 @@ static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { kk_duration_t d; d.seconds = t.tv_sec; d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; - return d; + return kk_duration_norm(d); } #else @@ -144,7 +144,7 @@ static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { const int64_t frac = t % ctx->timer_freq; const int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; d.attoseconds = frac * resolution; - return d; + return kk_duration_norm(d); } #endif #endif @@ -152,14 +152,17 @@ static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx) { const kk_duration_t d = kk_timer_ticks_prim(ctx); // init previous and delta - if (kk_duration_is_zero(ctx->timer_prev)) { + if kk_unlikely(kk_duration_is_zero(ctx->timer_prev)) { ctx->timer_prev = d; ctx->timer_delta = d; } // check monotonicity - if (kk_duration_is_gt( ctx->timer_prev, d)) { - // ouch, clock ran backward; add 1 nano second and adjust the delta - ctx->timer_delta = kk_duration_sub(kk_duration_sub(ctx->timer_prev, d), kk_duration_from_nsecs(1)); + else if kk_unlikely(kk_duration_is_gt(ctx->timer_prev, d)) { + // ouch, clock ran backward! + // we adjust the delta to return the previous time + 1ns to maintain monotonicity. + // that is the return value is: d - new_delta == timer_prev + 1ns + // and thus: new_delta = d - timer_prev - 1ns + ctx->timer_delta = kk_duration_sub(kk_duration_sub(d, ctx->timer_prev), kk_duration_from_nsecs(1)); } // save time in previous and adjust with the delta ctx->timer_prev = d; From fe300091db008f66c336627bd0f94013b39fd3b3 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 5 Jan 2023 10:07:07 -0800 Subject: [PATCH 116/233] fix portable time --- kklib/include/kklib.h | 2 +- kklib/src/time.c | 20 ++++++++++++++------ 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 7e486bd96..97881c8ea 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 102 // modify on changes to trigger recompilation +#define KKLIB_BUILD 101 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/src/time.c b/kklib/src/time.c index 07a25a3d5..08e2bf1d0 100644 --- a/kklib/src/time.c +++ b/kklib/src/time.c @@ -197,7 +197,7 @@ static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { ctx->time_freq = KK_100NSECS_PER_SEC; } // done - return d; + return kk_duration_norm(d); } #else @@ -208,10 +208,15 @@ static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq==0) { struct timespec tres = { 0, 0 }; clock_getres(CLOCK_REALTIME, &tres); - if (tres.tv_sec == 0 && tres.tv_nsec > 0 && tres.tv_nsec <= KK_NSECS_PER_SEC && (tres.tv_nsec % KK_NSECS_PER_SEC) == 0) { + if (tres.tv_sec == 0 && tres.tv_nsec > 0 && tres.tv_nsec <= KK_NSECS_PER_SEC) { + kk_assert((KK_NSECS_PER_SEC % tres.tv_nsec) == 0); ctx->time_freq = (KK_NSECS_PER_SEC / tres.tv_nsec); } + else if (tres.tv_sec == 1 && tres.tv_nsec == 0) { + ctx->time_freq = 1; + } else { + kk_assert(false); // should never happen? ctx->time_freq = KK_NSECS_PER_SEC; } } @@ -220,20 +225,21 @@ static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { kk_duration_t d; d.seconds = t.tv_sec; d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; - return d; + return kk_duration_norm(d); } #else // portable 1s resolution time static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq == 0) { - ctx->time_freq = 1; // :-( + ctx->time_freq = 1; } time_t t; time(&t); kk_duration_t d; d.seconds = t; d.attoseconds = 0; + return kk_duration_norm(d); } #endif @@ -243,8 +249,10 @@ kk_decl_export kk_duration_t kk_time_unix_now(kk_context_t* ctx) { kk_duration_t d = kk_time_unix_now_prim(ctx); if (kk_duration_is_gt(ctx->time_unix_prev, d) // time is set backward! - // if it is less the 1 second we add a tiny increment as we assume it is due to leap second smearing - && !kk_duration_is_gt(ctx->time_unix_prev, kk_duration_add(d,kk_duration_from_secs(1))) ) { + // if it is less then 1 second we add a tiny increment as we assume it is due to leap second smearing + // (so we ensure at least monotonicity during a leap second) + && !kk_duration_is_gt(ctx->time_unix_prev, kk_duration_add(d,kk_duration_from_secs(1))) ) + { // keep monotonic and allow to catch up d = kk_duration_add(ctx->time_unix_prev, kk_duration_from_nsecs(1)); } From fb0d255b241e999f37b65e316a7ca1ee04df8fc0 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 5 Jan 2023 14:04:24 -0800 Subject: [PATCH 117/233] more precise chrono --- kklib/include/kklib/os.h | 2 +- kklib/test/main.c | 68 ++++++++++++++++++++++++++++++++++-- lib/std/time/chrono-inline.c | 47 +++++++++++++++++++++++-- 3 files changed, 110 insertions(+), 7 deletions(-) diff --git a/kklib/include/kklib/os.h b/kklib/include/kklib/os.h index 083c05099..cc49d1142 100644 --- a/kklib/include/kklib/os.h +++ b/kklib/include/kklib/os.h @@ -56,7 +56,7 @@ kk_decl_export kk_duration_t kk_duration_add(kk_duration_t x, kk_duration_t y); kk_decl_export kk_duration_t kk_duration_neg(kk_duration_t x); kk_decl_export kk_duration_t kk_duration_from_secs(int64_t secs); kk_decl_export kk_duration_t kk_duration_from_nsecs(int64_t nsecs); - +kk_decl_export kk_duration_t kk_duration_norm(kk_duration_t x); kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx); kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); diff --git a/kklib/test/main.c b/kklib/test/main.c index 8fe0510db..77e5339be 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -565,9 +565,70 @@ static void test_ovf(kk_context_t* ctx) { printf("\nint-inc-dec: %6.3fs\n", (double)end / 1000.0); } + +typedef struct kk_ddouble_s { + double hi; + double lo; +} kk_ddouble_t; + +kk_ddouble_t kk_dd_sum(double x, double y) { + double z = x + y; + double diff = z - x; + double err = (x - (z - diff)) + (y - diff); + kk_ddouble_t d = { z, err }; + return d; +} + +kk_ddouble_t kk_dd_quicksum(double x, double y) { + kk_assert(abs(x) >= abs(y)); + double z = x + y; + double err = y - (z - x); + kk_ddouble_t d = { z, err }; + return d; +} + +kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { + kk_ddouble_t z1 = kk_dd_sum(x.hi, y.hi); + kk_ddouble_t low = kk_dd_sum(x.lo, y.lo); + double e1 = z1.lo + low.hi; + kk_ddouble_t z2 = kk_dd_quicksum(z1.hi, e1); + double e2 = z2.lo + low.lo; + return kk_dd_quicksum(z2.hi, e2); +} + +kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { + double x = (double)(kk_sar64(i, 32) * 0x1p32) * scale; + double y = (double)((int32_t)i) * scale; + return kk_dd_sum(x, y); +} + +void kk_duration_to_ddouble(kk_duration_t d, double* psecs, double* pfrac) { + kk_assert(d.attoseconds >= 0 && d.seconds != INT64_MIN); + kk_ddouble_t dd = kk_dd_add(kk_dd_from_int64(d.seconds,1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); + + int64_t secs = d.seconds; + int64_t asecs = d.attoseconds; + int sbits = 64 - kk_bits_clz64((uint64_t)secs); // bits used by the seconds + printf("duration: %20llus %lluas, sbits: %d, %20fs . %fs, %.18fs . %.18fs\n", secs, asecs, sbits, (double)secs, (double)asecs * 1e-18, dd.hi, dd.lo); + + if (psecs != NULL) *psecs = dd.hi; + if (pfrac != NULL) *pfrac = dd.lo; +} + +void test_duration1(void) { + for (int64_t i = 1; i < (INT64_MAX/2); i <<= 1) { + kk_duration_t d; + d.seconds = i; + d.attoseconds = KK_I64(1000000000) * KK_I64(1000000000) - 1; + d = kk_duration_norm(d); + kk_duration_to_ddouble(d, NULL, NULL); + } +} + int main() { kk_context_t* ctx = kk_get_context(); + test_fib(50, ctx); // 12586269025 test_fib(150, ctx); // 9969216677189303386214405760200 test_fib(300, ctx); // 22223224462942044552973989346190996720666693909649976499097960 @@ -584,12 +645,13 @@ int main() { test_pow10(ctx); test_double(ctx); test_ovf(ctx); - + test_count10(ctx); - //test_popcount(); test_bitcount(); + //test_popcount(); //test_random(ctx); - + //test_duration1(); + /* init_nums(); for (int i = 100; i < 800; i+=50) { diff --git a/lib/std/time/chrono-inline.c b/lib/std/time/chrono-inline.c index 6b797b5f8..c932166e7 100644 --- a/lib/std/time/chrono-inline.c +++ b/lib/std/time/chrono-inline.c @@ -6,11 +6,52 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ +// Use double-double type for high precision conversion from duration to two doubles. +typedef struct kk_ddouble_s { + double hi; + double lo; +} kk_ddouble_t; + +static kk_ddouble_t kk_dd_sum(double x, double y) { + double z = x + y; + double diff = z - x; + double err = (x - (z - diff)) + (y - diff); + kk_ddouble_t dd = { z, err }; + return dd; +} + +static kk_ddouble_t kk_dd_quicksum(double x, double y) { + kk_assert(abs(x) >= abs(y)); + double z = x + y; + double err = y - (z - x); + kk_ddouble_t dd = { z, err }; + return dd; +} + +static kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { + kk_ddouble_t z1 = kk_dd_sum(x.hi, y.hi); + kk_ddouble_t low = kk_dd_sum(x.lo, y.lo); + double e1 = z1.lo + low.hi; + kk_ddouble_t z2 = kk_dd_quicksum(z1.hi, e1); + double e2 = z2.lo + low.lo; + return kk_dd_quicksum(z2.hi, e2); +} + +static kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { + double x = ((double)kk_sar64(i,32) * 0x1p32) * scale; + double y = (double)((int32_t)i) * scale; + return kk_dd_sum(x, y); +} + +static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { + return kk_dd_add(kk_dd_from_int64(d.seconds,1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); +} + + static kk_std_core_types__tuple2_ kk_time_unix_now_tuple(kk_context_t* ctx) { kk_duration_t d = kk_time_unix_now(ctx); - double frac = (double)d.attoseconds * 1e-18; - double secs = (double)d.seconds; - return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); + kk_ddouble_t dd = kk_dd_from_duration(d); + return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(dd.hi,ctx), kk_double_box(dd.lo,ctx), ctx ); } static double kk_time_dresolution(kk_context_t* ctx) { From df163e028986716a92fe5b97549ff5a116e6da4b Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 5 Jan 2023 17:58:31 -0800 Subject: [PATCH 118/233] chrono and timer with standard conversion --- kklib/test/main.c | 54 ++++++++++++++++++++++++------------ lib/std/time/chrono-inline.c | 49 ++++---------------------------- lib/std/time/timer-inline.c | 4 ++- 3 files changed, 45 insertions(+), 62 deletions(-) diff --git a/kklib/test/main.c b/kklib/test/main.c index 77e5339be..1971a5c8e 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -566,28 +566,29 @@ static void test_ovf(kk_context_t* ctx) { } +// Use double-double type for high precision conversion from duration to two doubles. typedef struct kk_ddouble_s { double hi; double lo; } kk_ddouble_t; -kk_ddouble_t kk_dd_sum(double x, double y) { +static kk_ddouble_t kk_dd_sum(double x, double y) { double z = x + y; double diff = z - x; double err = (x - (z - diff)) + (y - diff); - kk_ddouble_t d = { z, err }; - return d; + kk_ddouble_t dd = { z, err }; + return dd; } -kk_ddouble_t kk_dd_quicksum(double x, double y) { +static kk_ddouble_t kk_dd_quicksum(double x, double y) { kk_assert(abs(x) >= abs(y)); double z = x + y; double err = y - (z - x); - kk_ddouble_t d = { z, err }; - return d; + kk_ddouble_t dd = { z, err }; + return dd; } -kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { +static kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { kk_ddouble_t z1 = kk_dd_sum(x.hi, y.hi); kk_ddouble_t low = kk_dd_sum(x.lo, y.lo); double e1 = z1.lo + low.hi; @@ -596,20 +597,38 @@ kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { return kk_dd_quicksum(z2.hi, e2); } -kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { - double x = (double)(kk_sar64(i, 32) * 0x1p32) * scale; - double y = (double)((int32_t)i) * scale; +static kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { + double x = ((double)kk_sar64(i,32) * 0x1p32) * scale; + double y = (double)((uint32_t)i) * scale; return kk_dd_sum(x, y); } -void kk_duration_to_ddouble(kk_duration_t d, double* psecs, double* pfrac) { - kk_assert(d.attoseconds >= 0 && d.seconds != INT64_MIN); - kk_ddouble_t dd = kk_dd_add(kk_dd_from_int64(d.seconds,1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); +#define KK_INT52_MAX ((KK_I64(1)<<51) - 1) +#define KK_INT52_MIN (-KK_INT52_MAX - 1) +static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { + if kk_likely((d.attoseconds % 1000) == 0 && // 1e-15 precision fits in 52 bits + d.seconds >= KK_INT52_MIN && d.seconds < KK_INT52_MAX) + { + // fast path when both components can be converted directly with full precision + kk_ddouble_t dd; + dd.hi = (double)(d.seconds); + dd.lo = (double)(d.attoseconds / 1000) * 1e-15; + return dd; + } + else { + // otherwise use ddouble arithmetic + return kk_dd_add(kk_dd_from_int64(d.seconds, 1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); + } +} + + +void kk_duration_to_ddouble(kk_duration_t d, double* psecs, double* pfrac) { + kk_ddouble_t dd = kk_dd_from_duration(d); int64_t secs = d.seconds; int64_t asecs = d.attoseconds; int sbits = 64 - kk_bits_clz64((uint64_t)secs); // bits used by the seconds - printf("duration: %20llus %lluas, sbits: %d, %20fs . %fs, %.18fs . %.18fs\n", secs, asecs, sbits, (double)secs, (double)asecs * 1e-18, dd.hi, dd.lo); + printf("duration: %20llus %lluas, sbits: %d, %20es . %fe, %.20es . %.20es\n", secs, asecs, sbits, (double)secs, (double)asecs * 1e-18, dd.hi, dd.lo); if (psecs != NULL) *psecs = dd.hi; if (pfrac != NULL) *pfrac = dd.lo; @@ -619,8 +638,10 @@ void test_duration1(void) { for (int64_t i = 1; i < (INT64_MAX/2); i <<= 1) { kk_duration_t d; d.seconds = i; - d.attoseconds = KK_I64(1000000000) * KK_I64(1000000000) - 1; - d = kk_duration_norm(d); + d.attoseconds = KK_I64(1000000000) * KK_I64(1000000000) - 1 - KK_I64(1000000000); + kk_duration_to_ddouble(d, NULL, NULL); + d.seconds += 1; + d.attoseconds = KK_I64(1000000000); kk_duration_to_ddouble(d, NULL, NULL); } } @@ -628,7 +649,6 @@ void test_duration1(void) { int main() { kk_context_t* ctx = kk_get_context(); - test_fib(50, ctx); // 12586269025 test_fib(150, ctx); // 9969216677189303386214405760200 test_fib(300, ctx); // 22223224462942044552973989346190996720666693909649976499097960 diff --git a/lib/std/time/chrono-inline.c b/lib/std/time/chrono-inline.c index c932166e7..89ab381aa 100644 --- a/lib/std/time/chrono-inline.c +++ b/lib/std/time/chrono-inline.c @@ -6,52 +6,13 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -// Use double-double type for high precision conversion from duration to two doubles. -typedef struct kk_ddouble_s { - double hi; - double lo; -} kk_ddouble_t; - -static kk_ddouble_t kk_dd_sum(double x, double y) { - double z = x + y; - double diff = z - x; - double err = (x - (z - diff)) + (y - diff); - kk_ddouble_t dd = { z, err }; - return dd; -} - -static kk_ddouble_t kk_dd_quicksum(double x, double y) { - kk_assert(abs(x) >= abs(y)); - double z = x + y; - double err = y - (z - x); - kk_ddouble_t dd = { z, err }; - return dd; -} - -static kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { - kk_ddouble_t z1 = kk_dd_sum(x.hi, y.hi); - kk_ddouble_t low = kk_dd_sum(x.lo, y.lo); - double e1 = z1.lo + low.hi; - kk_ddouble_t z2 = kk_dd_quicksum(z1.hi, e1); - double e2 = z2.lo + low.lo; - return kk_dd_quicksum(z2.hi, e2); -} - -static kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { - double x = ((double)kk_sar64(i,32) * 0x1p32) * scale; - double y = (double)((int32_t)i) * scale; - return kk_dd_sum(x, y); -} - -static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { - return kk_dd_add(kk_dd_from_int64(d.seconds,1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); -} - - static kk_std_core_types__tuple2_ kk_time_unix_now_tuple(kk_context_t* ctx) { kk_duration_t d = kk_time_unix_now(ctx); - kk_ddouble_t dd = kk_dd_from_duration(d); - return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(dd.hi,ctx), kk_double_box(dd.lo,ctx), ctx ); + // the conversion has about 15 digits of precision + // we cannot do this more precisely as the api expects the fraction between 0.0 and 2.0 (for leap seconds). + double secs = (double)d.seconds; + double frac = (double)d.attoseconds * 1e-18; + return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } static double kk_time_dresolution(kk_context_t* ctx) { diff --git a/lib/std/time/timer-inline.c b/lib/std/time/timer-inline.c index da746bd46..1481fb9a9 100644 --- a/lib/std/time/timer-inline.c +++ b/lib/std/time/timer-inline.c @@ -8,8 +8,10 @@ static kk_std_core_types__tuple2_ kk_timer_ticks_tuple(kk_context_t* ctx) { kk_duration_t d = kk_timer_ticks(ctx); - double frac = (double)d.attoseconds * 1e-18; + // the conversion has about 15 digits of precision + // we cannot do this more precisely as the api expects the fraction between 0.0 and 2.0 (for leap seconds). double secs = (double)d.seconds; + double frac = (double)d.attoseconds * 1e-18; return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } From b76984eb9dfd23a59ae43ad2220d8a05d4ab9648 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 6 Jan 2023 16:12:09 -0800 Subject: [PATCH 119/233] improve chrono/timer precision --- lib/std/num/ddouble.kk | 16 ++++++++++------ lib/std/time/chrono.kk | 4 +++- lib/std/time/duration.kk | 4 ++++ lib/std/time/timer.kk | 2 +- lib/std/time/timestamp.kk | 3 +++ lib/std/time/utc.kk | 10 +++++----- 6 files changed, 26 insertions(+), 13 deletions(-) diff --git a/lib/std/num/ddouble.kk b/lib/std/num/ddouble.kk index 77bd16ef7..3170eb924 100644 --- a/lib/std/num/ddouble.kk +++ b/lib/std/num/ddouble.kk @@ -1,5 +1,5 @@ /*--------------------------------------------------------------------------- - Copyright 2017-2021, Microsoft Research, Daan Leijen. + Copyright 2017-2022, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -87,14 +87,13 @@ exact : 3.14784204874900425235885265494550774498...e-16 ```` For this kind of example, a `:ddouble` has better precision than a regular 128-bit IEEE float since it can combine very large and -small values. (Kahan [@Kahan:triangle] shows how to rewrite the equations -to avoid magnifying rounding errors -- in that case the result for -IEEE 128-bit floats becomes: +small values. Note that Kahan [@Kahan:triangle] shows how to rewrite the area equation +to avoid magnifying rounding errors -- in that case the result for IEEE 128-bit floats becomes: ```` 128-bit ieee x : 3.147842048749004252358852654945507\([92210]{color:#F88}\)e-16 ```` -The implementation is based closely on the [QD] C++ library [@Hida:qd;@Hida:qdlib], +The implementation is based closely on the excellent [QD] C++ library [@Hida:qd;@Hida:qdlib], and assumes proper 64-bit IEEE `:float64`s with correct rounding. Integers can be represented precisely up to 30 decimal digits (and a bit more... up to 2^106^ - 2). @@ -166,7 +165,7 @@ import std/num/float64 import std/num/decimal import std/text/parse -/* The `:ddouble` type implements [float64 float64][ddwiki] 128-bit floating point numbers +/* The `:ddouble` type implements [double double][ddwiki] 128-bit floating point numbers as a pair of IEEE `:float64` values. This extends the precision to 31 decimal digits (versus 15 for `:float64`), but keeps the same range as a `:float64` with a maximum value of about 1.8·10^308^. Because @@ -417,6 +416,11 @@ pub fun (+)( x : ddouble, y : ddouble ) : ddouble val e2 = z2.err + lo.err dquicksum(z2.num,e2) + +// Create a `:ddouble` as the sum of two `:float64`'s. +pub fun ddouble( x : float64, y : float64 ) : ddouble + if y.is-zero then ddouble(x) else dsum(x,y) + // Negate a `:ddouble`. pub fun (~)( x : ddouble ) : ddouble Ddouble(~x.hi,~x.lo) diff --git a/lib/std/time/chrono.kk b/lib/std/time/chrono.kk index 05b353ece..8c97a5652 100644 --- a/lib/std/time/chrono.kk +++ b/lib/std/time/chrono.kk @@ -11,6 +11,7 @@ */ module std/time/chrono +import std/time/timestamp import std/time/duration import std/time/instant import std/time/utc @@ -52,7 +53,8 @@ pub fun now() : instant pub fun now-in( ts : timescale = ts-ti) : ndet instant // on current backends (C#, JavaScript) we can only use `unix-now` :-( val (secs,frac) = unix-now() - unix-instant(secs,frac,ts) + val leap = 0 + unix-instant(timespan(secs,frac),leap,ts) // Returns a unix time stamp as seconds and fraction of seconds; // The fraction of seconds is for added precision if necessary, diff --git a/lib/std/time/duration.kk b/lib/std/time/duration.kk index d45b579e0..1e09b8f99 100644 --- a/lib/std/time/duration.kk +++ b/lib/std/time/duration.kk @@ -50,6 +50,10 @@ pub fun duration( secs : int, frac : float64 = 0.0 ) : duration pub fun duration( secs : float64 ) : duration Duration(timespan(secs)) +// Create a duration from seconds and a fraction as a `:float64`'s. +pub fun duration( secs : float64, frac : float64 ) : duration + Duration(timespan(secs,frac)) + // Convert a duration to a `:timespan`. pub fun timespan( d : duration ) : timespan d.seconds diff --git a/lib/std/time/timer.kk b/lib/std/time/timer.kk index e812cf988..7ce93a2ca 100644 --- a/lib/std/time/timer.kk +++ b/lib/std/time/timer.kk @@ -29,7 +29,7 @@ extern import // and have at least millisecond resolution. pub fun ticks() : ndet duration val (secs,frac) = xticks() - duration(secs.truncate.int, secs.fraction + frac) + duration(secs,frac) extern xticks() : ndet (float64,float64) c "kk_timer_ticks_tuple" diff --git a/lib/std/time/timestamp.kk b/lib/std/time/timestamp.kk index 0512422f5..8389a5e3a 100644 --- a/lib/std/time/timestamp.kk +++ b/lib/std/time/timestamp.kk @@ -32,6 +32,9 @@ pub fun timespan( seconds : int, frac : float64 = 0.0 ) : timespan pub fun timespan( secs : float64 ) : timespan ddouble(secs) +pub fun timespan( secs : float64, frac : float64 ) : timespan + ddouble(secs,frac) + // Timespan from a `:ddouble`. Just for convenience as `:timespan` is an alias pub fun timespan( secs : ddouble ) : timespan secs diff --git a/lib/std/time/utc.kk b/lib/std/time/utc.kk index 3b41e282d..9b1439ce9 100644 --- a/lib/std/time/utc.kk +++ b/lib/std/time/utc.kk @@ -339,14 +339,14 @@ To indicate a time in a leap second, you can use a fraction `frac` that is large This works well for systems that support [``CLOCK_UTC``](http://www.madore.org/~david/computers/unix-leap-seconds.html). */ pub fun unix-instant( u : float64, frac : float64 = 0.0, ts : timescale = ts-ti ) : instant - val t = u.ddouble + frac.fraction.ddouble + val t = timespan(u,frac.fraction) val leap = frac.truncate.int unix-instant(t,leap,ts) // Create an instant from raw unix seconds since the unix epoch (1970-01-01T00:00:10 TAI) // Use a fraction `> 1` to indicate a time inside a leap second. pub fun unix-instant( u : int, frac : float64 = 0.0, ts : timescale = ts-ti ) : instant - val t = u.ddouble + frac.fraction.ddouble + val t = timespan(u.ddouble + frac.fraction.ddouble) val leap = frac.truncate.int unix-instant(t,leap,ts) @@ -491,14 +491,14 @@ to +33. This looks like: UTC-to-TAI-delta: ... +32 | +33 ... UTC timestamp 189388799 189388799+1 189388800 -UTC 2015-12-31T23:59: 59 60 leap 00 +UTC 2005-12-31T23:59: 59 60 leap 00 ---------|-----------|xxxxxxxxxxxx|------------- | | | -TAI 2016-01-01T00:00: 31 32 33 +TAI 2006-01-01T00:00: 31 32 33 TAI timestamp: 189388831 189388832 189388833 In the code below, suppose `tai` is `189388832.5`. -The we estimate at first the delta `dtai0` to +33, so our +Then we estimate at first the delta `dtai0` to +33, so our estimate `utc0` is `189388799.5` (just before the leap step!). We then use `utc0` to get delta-TAI at that time, +32 and set the difference `diff` to `(33-32) == 1` -- the time of the From 1f6755343a351eea4384f1a36652b97b04a44eed Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Fri, 6 Jan 2023 16:38:56 -0800 Subject: [PATCH 120/233] wip: testing --- kklib/test/main.c | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/kklib/test/main.c b/kklib/test/main.c index 1971a5c8e..902ae2b48 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -607,6 +607,27 @@ static kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { #define KK_INT52_MIN (-KK_INT52_MAX - 1) static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { + if kk_likely(d.attoseconds % KK_I64(1000000000) == 0) { + int64_t nsecs = (d.attoseconds / KK_I64(1000000000)); + if ((int32_t)nsecs == nsecs) { + double frac = ((double)nsecs * 1e-9); + double secs; + if ((int32_t)secs == d.seconds) { + secs = (double)d.seconds; + } + else { + double sign = (d.seconds < 0 ? -1.0 : 1.0); + int64_t s = (d.seconds < 0 ? -d.seconds : d.seconds); + secs = sign * ((double)kk_shr64(s, 16) * 0x1p16); + frac = frac + (sign * (double)((uint16_t)s) * 1e18); + } + kk_ddouble_t dd; + dd.hi = secs; + dd.lo = frac; + return dd; + } + } + if kk_likely((d.attoseconds % 1000) == 0 && // 1e-15 precision fits in 52 bits d.seconds >= KK_INT52_MIN && d.seconds < KK_INT52_MAX) { From c74735ab1ef68ed0f2ce07e68e61c29f29626cc0 Mon Sep 17 00:00:00 2001 From: Daan Date: Wed, 11 Jan 2023 17:15:45 -0800 Subject: [PATCH 121/233] fix arch --- src/Compiler/Options.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index e8a2e27fa..22175fb37 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -963,10 +963,10 @@ buildVariant flags WasmJs -> "-wasmjs" WasmWeb-> "-wasmweb" _ | platformHasCompressedFields (platform flags) - -> "-x" ++ show (8 * sizePtr (platform flags)) ++ "c" + -> "-" ++ cpuArch ++ "c" | otherwise -> "") - JS _ -> "js" - _ -> show (target flags) + JS _ -> "-js" + _ -> "-" ++ show (target flags) in pre ++ "-" ++ show (buildType flags) From e275ae9faf27fa9811c7d0e1e7ed5053c7ee9053 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 31 Jan 2023 21:14:10 -0800 Subject: [PATCH 122/233] add comments --- src/Backend/C/Parc.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 5e7bd580a..fefdb3d38 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -7,9 +7,18 @@ ----------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- precise automatic reference counting ------------------------------------------------------------------------------ +{---------------------------------------------------------------------------- +-- precise automatic reference counting (now called "Perceus") +-- See: https://www.microsoft.com/en-us/research/uploads/prod/2020/11/perceus-tr-v4.pdf + +Notes: +- The monad has a borrowed and owned (multi-set) environment just like the paper +- The live variable set is a state +- To calculate the live variables we visit the expression tree _in reverse_ + (see the parcDefGroup, and parcExpr for let-bindings and applications for example) +- That still works with the borrowed and owned environments as those stay + the same in a scope. +----------------------------------------------------------------------------} module Backend.C.Parc ( parcCore ) where From 0e822c4565f670aa8d3c967ed245afd116cca6c0 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 31 Jan 2023 21:43:54 -0800 Subject: [PATCH 123/233] initial framework for fbip check --- koka.cabal | 1 + src/Compiler/Compile.hs | 3 + src/Core/CheckFBIP.hs | 152 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 156 insertions(+) create mode 100644 src/Core/CheckFBIP.hs diff --git a/koka.cabal b/koka.cabal index ce7e76ea7..73c03f8db 100644 --- a/koka.cabal +++ b/koka.cabal @@ -58,6 +58,7 @@ executable koka Core.BindingGroups Core.Borrowed Core.Check + Core.CheckFBIP Core.Core Core.CoreVar Core.CTail diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index ee1ee3ffe..52114894a 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -58,6 +58,7 @@ import Syntax.Colorize ( colorize ) import Core.GenDoc ( genDoc ) import Core.Check ( checkCore ) import Core.UnReturn ( unreturn ) +import Core.CheckFBIP ( checkFBIP ) import Core.OpenResolve ( openResolve ) import Core.FunLift ( liftFunctions ) import Core.Monadic ( monTransform ) @@ -866,6 +867,8 @@ inferCheck loaded0 flags line coreImports program unreturn penv -- checkCoreDefs "unreturn" + checkFBIP penv (platform flags) (loadedNewtypes loaded) (loadedBorrowed loaded) + -- initial simplify let ndebug = optimize flags > 0 simplifyX dupMax = simplifyDefs penv False {-unsafe-} ndebug (simplify flags) dupMax diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs new file mode 100644 index 000000000..d8c9471dd --- /dev/null +++ b/src/Core/CheckFBIP.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------------------------- +-- Copyright 2020-2022, Microsoft Research, Daan Leijen, Anton Lorenzen +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- +-- Check if a function is FBIP +----------------------------------------------------------------------------- + +module Core.CheckFBIP( checkFBIP + ) where + + +import qualified Lib.Trace +import Control.Monad +import Control.Applicative +import Data.List( partition, intersperse ) + +import Lib.PPrint +import Common.Failure +import Common.Name +import Common.Range +import Common.Unique +import Common.Error +import Common.Syntax + +import Kind.Kind +import Kind.Newtypes + +import Type.Type +import Type.Kind +import Type.TypeVar +import Type.Pretty hiding (Env) +import qualified Type.Pretty as Pretty +import Type.Assumption +import Core.Core +import qualified Core.Core as Core +import Core.Pretty +import Core.CoreVar +import Core.Borrowed + +trace s x = + Lib.Trace.trace s + x + + +checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> CorePhase () +checkFBIP penv platform newtypes borrowed + = do uniq <- unique + defGroups <- getCoreDefs + let (_,docs) = runChk penv uniq platform newtypes borrowed (chkDefGroups True defGroups) + mapM (\doc -> liftError (warningMsg (rangeNull, doc))) docs + return () + + + +{-------------------------------------------------------------------------- + check definition groups +--------------------------------------------------------------------------} + +chkDefGroups :: Bool -> DefGroups -> Chk () +chkDefGroups topLevel defGroups + = return () + + +{-------------------------------------------------------------------------- + Chk monad +--------------------------------------------------------------------------} +newtype Chk a = Chk (Env -> State -> Result a) + +data Env = Env{ currentDef :: [Def], + prettyEnv :: Pretty.Env, + platform :: Platform, + newtypes :: Newtypes, + borrowed :: Borrowed + } + +data State = State{ uniq :: Int } + +data Result a = Ok a State [Doc] + +runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Chk a -> (a,[Doc]) +runChk penv u platform newtypes borrowed (Chk c) + = case c (Env [] penv platform newtypes borrowed) (State u) of + Ok x st docs -> (x,docs) + +instance Functor Chk where + fmap f (Chk c) = Chk (\env st -> case c env st of + Ok x st' dgs -> Ok (f x) st' dgs) + +instance Applicative Chk where + pure = return + (<*>) = ap + +instance Monad Chk where + return x = Chk (\env st -> Ok x st []) + (Chk c) >>= f = Chk (\env st -> case c env st of + Ok x st' dgs -> case f x of + Chk d -> case d env st' of + Ok x' st'' dgs' -> Ok x' st'' (dgs ++ dgs')) + +instance HasUnique Chk where + updateUnique f = Chk (\env st -> Ok (uniq st) st{ uniq = (f (uniq st)) } []) + setUnique i = Chk (\env st -> Ok () st{ uniq = i} []) + + +withEnv :: (Env -> Env) -> Chk a -> Chk a +withEnv f (Chk c) + = Chk (\env st -> c (f env) st) + +getEnv :: Chk Env +getEnv + = Chk (\env st -> Ok env st []) + +updateSt :: (State -> State) -> Chk State +updateSt f + = Chk (\env st -> Ok st (f st) []) + +-- track the current definition for nicer error messages +withCurrentDef :: Def -> Chk a -> Chk a +withCurrentDef def action + = -- trace ("chking: " ++ show (defName def)) $ + withEnv (\env -> env{currentDef = def:currentDef env}) $ + action + +currentDefNames :: Chk [Name] +currentDefNames + = do env <- getEnv + return (map defName (currentDef env)) + +traceDoc :: (Pretty.Env -> Doc) -> Chk () +traceDoc f + = do env <- getEnv + chkTrace (show (f (prettyEnv env))) + +chkTrace :: String -> Chk () +chkTrace msg + = do env <- getEnv + trace ("chk: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +emitDoc :: Doc -> Chk () +emitDoc doc + = Chk (\env st -> Ok () st [doc]) + +emitWarning :: Doc -> Chk () +emitWarning doc + = do names <- currentDefNames + let fdoc = text (show names) <.> colon <+> doc + emitDoc fdoc \ No newline at end of file From dae6b72f3d0096317fb038c76d41936dcd856a17 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Wed, 8 Feb 2023 19:42:15 +0000 Subject: [PATCH 124/233] Initial FBIPness check (more work needed on unboxing and handling of algeff primitives) --- src/Backend/C/Parc.hs | 2 +- src/Backend/C/ParcReuse.hs | 33 +-- src/Core/CheckFBIP.hs | 416 +++++++++++++++++++++++++++++++++---- 3 files changed, 400 insertions(+), 51 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index fefdb3d38..cc9eca037 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -164,7 +164,7 @@ parcExpr expr -> do name <- uniqueName "res" -- name the result return def{defName = name} _ -> return def - body1 <- ownedInScope (bv def1) $ parcExpr (Let dgs body) + body1 <- ownedInScope (S.singleton $ defTName def1) $ parcExpr (Let dgs body) def2 <- parcDef False def1 return $ makeLet [DefNonRec def2] body1 Let (DefRec _ : _) _ diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index cd7fbd180..ab684882f 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -13,7 +13,7 @@ module Backend.C.ParcReuse ( parcReuseCore, orderConFieldsEx, newtypesDataDefRepr, hasTagField, - constructorSizeOf + constructorSizeOf, getConSize ) where import Lib.Trace (trace) @@ -578,25 +578,29 @@ ruTrace msg ---------------- --- | If all constructors of a type have the same shape, --- return the byte size and number of scan fields. getRuConSize :: Type -> Reuse (Maybe (Int, Int)) getRuConSize dataType = do newtypes <- getNewtypes platform <- getPlatform - let mdataName = extractDataName dataType - if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName - then return Nothing else do - let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName + pure $ getConSize newtypes platform dataType + +-- | If all constructors of a type have the same shape, +-- return the byte size and number of scan fields. +getConSize :: Newtypes -> Platform -> Type -> Maybe (Int, Int) +getConSize newtypes platform dataType + = let mdataName = extractDataName dataType in + if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName + then Nothing else + let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName in case mdataInfo of Just dataInfo - -> do let (dataRepr, _) = getDataRepr dataInfo - let cis = dataInfoConstrs dataInfo - let sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis - case sizes of - (s:ss) | all (==s) ss -> pure $ Just s - _ -> pure Nothing - _ -> pure Nothing + -> let (dataRepr, _) = getDataRepr dataInfo + cis = dataInfoConstrs dataInfo + sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis + in case sizes of + (s:ss) | all (==s) ss -> Just s + _ -> Nothing + _ -> Nothing where extractDataName :: Type -> Maybe Name extractDataName tp @@ -605,7 +609,6 @@ getRuConSize dataType TCon tc -> Just (typeConName tc) _ -> Nothing - -- return the allocated size of a constructor. Return 0 for value types or singletons constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) constructorSizeOf _ _ _ repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index d8c9471dd..5d22c8841 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -17,7 +17,9 @@ module Core.CheckFBIP( checkFBIP import qualified Lib.Trace import Control.Monad import Control.Applicative -import Data.List( partition, intersperse ) +import Data.List( partition, intersperse, foldl1', foldl', isSuffixOf, uncons ) +import qualified Data.Set as S +import qualified Data.Map as M import Lib.PPrint import Common.Failure @@ -41,6 +43,8 @@ import qualified Core.Core as Core import Core.Pretty import Core.CoreVar import Core.Borrowed +import Common.NamePrim (nameEffectEmpty, nameTpDiv) +import Backend.C.ParcReuse (constructorSizeOf,getConSize) trace s x = Lib.Trace.trace s @@ -51,61 +55,248 @@ checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> CorePhase () checkFBIP penv platform newtypes borrowed = do uniq <- unique defGroups <- getCoreDefs - let (_,docs) = runChk penv uniq platform newtypes borrowed (chkDefGroups True defGroups) - mapM (\doc -> liftError (warningMsg (rangeNull, doc))) docs - return () - + let (_,docs) = runChk penv uniq platform newtypes borrowed (chkDefGroups defGroups) + mapM_ (\doc -> liftError (warningMsg (rangeNull, doc))) docs {-------------------------------------------------------------------------- check definition groups --------------------------------------------------------------------------} -chkDefGroups :: Bool -> DefGroups -> Chk () -chkDefGroups topLevel defGroups - = return () - +chkDefGroups :: DefGroups -> Chk () +chkDefGroups = mapM_ chkDefGroup + +chkDefGroup :: DefGroup -> Chk () +chkDefGroup defGroup + = case defGroup of + DefRec defs -> mapM_ (chkTopLevelDef (map defName defs)) defs + DefNonRec def -> chkTopLevelDef [defName def] def + +chkTopLevelDef :: [Name] -> Def -> Chk () +chkTopLevelDef defGroupNames def + = withCurrentDef def $ do + out <- extractOutput $ withInput (\_ -> Input S.empty [] defGroupNames True) $ + chkTopLevelExpr (defSort def) (defExpr def) + checkOutputEmpty out + +-- | Lambdas at the top-level are part of the signature and not allocations. +chkTopLevelExpr :: DefSort -> Expr -> Chk () +chkTopLevelExpr (DefFun bs) (Lam pars eff body) + = do chkEffect eff + let bpars = map snd $ filter ((==Borrow) . fst) $ zipDefault Own bs pars + let opars = map snd $ filter ((==Own) . fst) $ zipDefault Own bs pars + withBorrowed (S.fromList $ map getName bpars) $ do + out <- extractOutput $ chkExpr body + writeOutput =<< foldM (flip bindName) out opars +chkTopLevelExpr def (TypeLam _ body) + = chkTopLevelExpr def body +chkTopLevelExpr def (TypeApp body _) + = chkTopLevelExpr def body +chkTopLevelExpr _ expr = chkExpr expr + +chkExpr :: Expr -> Chk () +chkExpr expr + = case expr of + TypeLam _ body -> chkExpr body + TypeApp body _ -> chkExpr body + Lam pars eff body + -> do chkEffect eff + requireCapability HasAlloc $ \ppenv -> Just $ + text "Lambdas are always allocated." + out <- extractOutput $ chkExpr body + writeOutput =<< foldM (flip bindName) out pars + + App fn args -> chkApp fn args + Var tname info -> markSeen tname info + + Let [] body -> chkExpr body + Let (DefNonRec def:dgs) body + -> do out <- extractOutput $ chkExpr (Let dgs body) + gamma2 <- bindName (defTName def) out + writeOutput gamma2 + withBorrowed (M.keysSet $ gammaNm gamma2) $ + withNonTailCtx $ chkExpr $ defExpr def + Let _ _ + -> unhandled $ text "FBIP check can not handle recursive let bindings." + + Case scrutinees branches + -> chkBranches scrutinees branches + Con _ _ -> pure () -- Atoms are non-allocated + Lit lit -> chkLit lit + +chkModCons :: [Expr] -> Chk () +chkModCons [] = pure () +chkModCons args + = do let (larg:rargs) = reverse args + withNonTailCtx $ mapM_ chkExpr rargs + chkExpr larg -- can be tail-mod-cons + +chkBranches :: [Expr] -> [Branch] -> Chk () +chkBranches scrutinees branches + = do whichBorrowed <- mapM chkScrutinee scrutinees + outs <- mapM (extractOutput . chkBranch whichBorrowed) branches + writeOutput =<< joinContexts outs + where + fromVar (Var tname _) = Just tname + fromVar _ = Nothing + +chkScrutinee :: Expr -> Chk ParamInfo +chkScrutinee expr@(Var tname info) + = do b <- isBorrowed tname + unless b $ markSeen tname info + pure (if b then Borrow else Own) +chkScrutinee expr + = do chkExpr expr + pure Own + +chkBranch :: [ParamInfo] -> Branch -> Chk () +chkBranch whichBorrowed (Branch pats guards) + = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zipDefault Own whichBorrowed pats + out <- extractOutput $ + withBorrowed (S.map getName $ bv $ map snd borPats) $ + mapM_ chkGuard guards + writeOutput =<< foldM (flip bindPattern) out (map snd ownPats) + +chkGuard :: Guard -> Chk () +chkGuard (Guard test expr) + = do out <- extractOutput $ chkExpr expr + withBorrowed (M.keysSet $ gammaNm out) $ + withNonTailCtx $ chkExpr test + writeOutput out + +bindPattern :: Pattern -> Output -> Chk Output +bindPattern (PatCon cname pats repr _ _ _ _ _) out + = do newtypes <- getNewtypes + platform <- getPlatform + let (size,_) = constructorSizeOf platform newtypes cname repr + bindAllocation size <$> foldM (flip bindPattern) out pats +bindPattern (PatVar tname pat) out + = bindName tname =<< bindPattern pat out +bindPattern (PatLit _) out = pure out +bindPattern PatWild out = pure out + +chkApp :: Expr -> [Expr] -> Chk () +chkApp (TypeLam _ fn) args = chkApp fn args +chkApp (TypeApp fn _) args = chkApp fn args +chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function + = do bs <- getParamInfos (getName tname) + withNonTailCtx $ mapM_ chkArg $ zipDefault Own bs args + input <- getInput + unless (isTailContext input) $ + requireCapability HasStack $ \ppenv -> + if getName tname `elem` defGroupNames input + then Just $ text "Non-tail call to (mutually) recursive function: " + else Nothing +chkApp (Con cname repr) args -- try reuse + = do chkModCons args + chkAllocation cname repr +chkApp fn args -- local function + = do withNonTailCtx $ mapM_ chkExpr args + isBapp <- case fn of -- does the bapp rule apply? + Var tname _ -> isBorrowed tname + _ -> pure False + unless isBapp $ do + requireCapability HasDealloc $ \ppenv -> Just $ + text "Owned calls to functions require deallocation." + chkExpr fn + +chkArg :: (ParamInfo, Expr) -> Chk () +chkArg (Own, expr) = chkExpr expr +chkArg (Borrow, Var tname info) = markBorrowed tname info +chkArg (Borrow, expr) + = do chkExpr expr + requireCapability HasDealloc $ \ppenv -> Just $ + text "Passing owned expressions as borrowed require deallocation." + +chkLit :: Lit -> Chk () +chkLit lit + = case lit of + LitInt _ -> pure () -- we do not care about allocating big integers + LitFloat _ -> pure () + LitChar _ -> pure () + LitString _ -> requireCapability HasAlloc $ \ppenv -> Just $ + text "Inline string literals are allocated. Consider lifting to toplevel to avoid this." + +chkWrap :: TName -> VarInfo -> Chk () +chkWrap tname info + = do bs <- getParamInfos (getName tname) + unless (Borrow `notElem` bs) $ + unhandled $ text "FBIP analysis detected that a top-level function was wrapped." + +chkAllocation :: TName -> ConRepr -> Chk () +chkAllocation cname repr | isConAsJust repr = pure () +chkAllocation cname repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = requireCapability HasAlloc $ \ppenv -> Just $ + cat [text "Types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] +chkAllocation cname repr + = do newtypes <- getNewtypes + platform <- getPlatform + let (size,_) = constructorSizeOf platform newtypes cname repr + getAllocation cname size + +-- Only total/empty effects or divergence +chkEffect :: Tau -> Chk () +chkEffect tp + = if isFBIP then pure () else + unhandled $ text "Algebraic effects other than div are not FBIP." + where + isFBIP = case expandSyn tp of + TCon tc -> typeConName tc `elem` [nameEffectEmpty,nameTpDiv] + _ -> False {-------------------------------------------------------------------------- Chk monad --------------------------------------------------------------------------} -newtype Chk a = Chk (Env -> State -> Result a) +newtype Chk a = Chk (Env -> Input -> Result a) data Env = Env{ currentDef :: [Def], prettyEnv :: Pretty.Env, platform :: Platform, newtypes :: Newtypes, - borrowed :: Borrowed + borrowed :: Borrowed } -data State = State{ uniq :: Int } +data Capability + = HasAlloc -- may allocate and dup + | HasDealloc -- may use drop and free + | HasStack -- may use non-tail recursion + deriving (Eq, Ord, Bounded, Enum) + +data Input = Input{ delta :: S.Set Name, + capabilities :: [Capability], + defGroupNames :: [Name], + isTailContext :: Bool } + +data Output = Output{ gammaNm :: M.Map Name Int, + gammaDia :: M.Map Int [TName] } + +instance Semigroup Output where + Output s1 m1 <> Output s2 m2 = Output (M.unionWith (+) s1 s2) (M.unionWith (++) m1 m2) + +instance Monoid Output where + mempty = Output M.empty M.empty -data Result a = Ok a State [Doc] +data Result a = Ok a Output [Doc] runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Chk a -> (a,[Doc]) runChk penv u platform newtypes borrowed (Chk c) - = case c (Env [] penv platform newtypes borrowed) (State u) of - Ok x st docs -> (x,docs) - + = case c (Env [] penv platform newtypes borrowed) (Input S.empty [] [] True) of + Ok x _out docs -> (x,docs) + instance Functor Chk where - fmap f (Chk c) = Chk (\env st -> case c env st of - Ok x st' dgs -> Ok (f x) st' dgs) + fmap f (Chk c) = Chk (\env input -> case c env input of + Ok x out dgs -> Ok (f x) out dgs) instance Applicative Chk where pure = return (<*>) = ap instance Monad Chk where - return x = Chk (\env st -> Ok x st []) - (Chk c) >>= f = Chk (\env st -> case c env st of - Ok x st' dgs -> case f x of - Chk d -> case d env st' of - Ok x' st'' dgs' -> Ok x' st'' (dgs ++ dgs')) - -instance HasUnique Chk where - updateUnique f = Chk (\env st -> Ok (uniq st) st{ uniq = (f (uniq st)) } []) - setUnique i = Chk (\env st -> Ok () st{ uniq = i} []) - + return x = Chk (\env input -> Ok x mempty []) + (Chk c) >>= f = Chk (\env input -> case c env input of + Ok x out dgs -> case f x of + Chk d -> case d env input of + Ok x' out' dgs' -> Ok x' (out <> out') (dgs ++ dgs')) withEnv :: (Env -> Env) -> Chk a -> Chk a withEnv f (Chk c) @@ -113,11 +304,157 @@ withEnv f (Chk c) getEnv :: Chk Env getEnv - = Chk (\env st -> Ok env st []) - -updateSt :: (State -> State) -> Chk State -updateSt f - = Chk (\env st -> Ok st (f st) []) + = Chk (\env st -> Ok env mempty []) + +withInput :: (Input -> Input) -> Chk a -> Chk a +withInput f (Chk c) + = Chk (\env st -> c env (f st)) + +getInput :: Chk Input +getInput + = Chk (\env st -> Ok st mempty []) + +writeOutput :: Output -> Chk () +writeOutput out + = Chk (\env st -> Ok () out []) + +-- | Run the given check, keep the warnings but extract the output. +extractOutput :: Chk () -> Chk Output +extractOutput (Chk f) + = Chk (\env st -> case f env st of + Ok () out doc -> Ok out mempty doc) + +useCapabilities :: [Capability] -> Chk a -> Chk a +useCapabilities cs + = withInput (\st -> st {capabilities = cs}) + +hasCapability :: Capability -> Chk Bool +hasCapability c + = do st <- getInput + pure $ c `elem` capabilities st + +-- | Perform a test if the capability is not present +-- and emit a warning if the test is unsuccessful. +requireCapability :: Capability -> (Pretty.Env -> Maybe Doc) -> Chk () +requireCapability cap test + = do hasCap <- hasCapability cap + unless hasCap $ do + env <- getEnv + case test (prettyEnv env) of + Just warning -> emitWarning warning + Nothing -> pure () + +unhandled :: Doc -> Chk () +unhandled doc + = do hasAll <- and <$> mapM hasCapability (enumFromTo minBound maxBound) + unless hasAll $ emitWarning doc + +withNonTailCtx :: Chk a -> Chk a +withNonTailCtx + = withInput (\st -> st { isTailContext = False }) + +withBorrowed :: S.Set Name -> Chk a -> Chk a +withBorrowed names action + = withInput (\st -> st { delta = S.union names (delta st) }) action + +isBorrowed :: TName -> Chk Bool +isBorrowed nm + = do st <- getInput + pure $ getName nm `S.member` delta st + +markSeen :: TName -> VarInfo -> Chk () +markSeen tname info | infoIsRefCounted info -- is locally defined? + = do b <- isBorrowed tname + if b + then requireCapability HasAlloc $ \ppenv -> Just $ + cat [text "Borrowed value used as owned (can cause allocations later): ", ppName ppenv (getName tname)] + else writeOutput (Output (M.singleton (getName tname) 1) M.empty) +markSeen tname info = chkWrap tname info -- wrap rule + +markBorrowed :: TName -> VarInfo -> Chk () +markBorrowed nm info + = do b <- isBorrowed nm + unless b $ do + markSeen nm info + when (infoIsRefCounted info) $ + requireCapability HasDealloc $ \ppenv -> Just $ + cat [text "Last use of variable is borrowed (this requires deallocation): ", ppName ppenv (getName nm)] + +getAllocation :: TName -> Int -> Chk () +getAllocation nm size + = writeOutput (Output mempty (M.singleton size [nm])) + +provideToken :: TName -> Int -> Output -> Chk Output +provideToken debugName size out + = do requireCapability HasDealloc $ \ppenv -> + let fittingAllocs = M.findWithDefault [] size (gammaDia out) in + if null fittingAllocs then Just $ + cat [text "Unused reuse token requiring deallocation provided by ", ppName ppenv (getName debugName)] + else Nothing + pure $ out { gammaDia = M.adjust tail size (gammaDia out) } + +joinContexts :: [Output] -> Chk Output +joinContexts [] = pure mempty +joinContexts cs + = do let unionNm = foldl1' (M.unionWith max) (map gammaNm cs) + let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs) + requireCapability HasDealloc $ \ppenv -> + let interNm = foldl1' (M.intersectionWith min) (map gammaNm cs) in + let interDia = foldl1' (M.intersectionWith chooseShorter) (map gammaDia cs) in + if interNm /= unionNm + then Just $ + cat [text "Not all branches use the same variables (this requires deallocation)."] + else if interDia /= unionDia + then Just $ + cat [text "Not all branches use the same reuse tokens (this requires deallocation)."] + else Nothing + pure (Output unionNm unionDia) + where + chooseLonger a b = if length a >= length b then a else b + chooseShorter a b = if length a <= length b then a else b + +bindName :: TName -> Output -> Chk Output +bindName nm out + = do newtypes <- getNewtypes + platform <- getPlatform + out <- case M.lookup (getName nm) (gammaNm out) of + Nothing -- unused, so available for drop-guided reuse! + -> case getConSize newtypes platform (tnameType nm) of + Nothing -> pure out + Just (sz, _) -> pure $ bindAllocation sz out + Just n + -> do when (n > 1) $ + requireCapability HasAlloc $ \ppenv -> Just $ + cat [text "Variable used multiple times (this can lead to allocation later): ", ppName ppenv (getName nm)] + pure out + pure (out { gammaNm = M.delete (getName nm) (gammaNm out) }) + +bindAllocation :: Int -> Output -> Output +bindAllocation size out + = out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } + +checkOutputEmpty :: Output -> Chk () +checkOutputEmpty out + = do case M.maxViewWithKey $ gammaNm out of + Nothing -> pure () + Just ((nm, _), _) + -> emitWarning $ text $ "FBIP analysis didn't bind a name (this is a bug!): " ++ show nm + case M.maxViewWithKey $ gammaDia out of + Just ((sz, c:_), _) | sz > 0 + -> requireCapability HasAlloc $ \ppenv -> Just $ + cat [text "Unreused constructor: ", ppName ppenv (getName c) ] + _ -> pure () + +zipDefault :: a -> [a] -> [b] -> [(a, b)] +zipDefault x [] (b:bs) = (x, b) : zipDefault x [] bs +zipDefault x (a:as) (b:bs) = (a, b) : zipDefault x as bs +zipDefault x _ [] = [] + +getNewtypes :: Chk Newtypes +getNewtypes = newtypes <$> getEnv + +getPlatform :: Chk Platform +getPlatform = platform <$> getEnv -- track the current definition for nicer error messages withCurrentDef :: Def -> Chk a -> Chk a @@ -127,10 +464,19 @@ withCurrentDef def action action currentDefNames :: Chk [Name] -currentDefNames +currentDefNames = do env <- getEnv return (map defName (currentDef env)) +-- | Return borrowing infos for a name. May return the empty list +-- if no borrowing takes place. +getParamInfos :: Name -> Chk [ParamInfo] +getParamInfos name + = do b <- borrowed <$> getEnv + case borrowedLookup name b of + Nothing -> return [] + Just pinfos -> return pinfos + traceDoc :: (Pretty.Env -> Doc) -> Chk () traceDoc f = do env <- getEnv @@ -143,7 +489,7 @@ chkTrace msg emitDoc :: Doc -> Chk () emitDoc doc - = Chk (\env st -> Ok () st [doc]) + = Chk (\env st -> Ok () mempty [doc]) emitWarning :: Doc -> Chk () emitWarning doc From 43469c2d323a4e9378ad84695c7277520a3ecbdc Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 10 Feb 2023 17:17:41 +0000 Subject: [PATCH 125/233] Better error messages and handling of algebraic effects --- src/Core/CheckFBIP.hs | 60 +++++++++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 16 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 5d22c8841..f2a0038b0 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -43,7 +43,7 @@ import qualified Core.Core as Core import Core.Pretty import Core.CoreVar import Core.Borrowed -import Common.NamePrim (nameEffectEmpty, nameTpDiv) +import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial) import Backend.C.ParcReuse (constructorSizeOf,getConSize) trace s x = @@ -135,7 +135,7 @@ chkBranches :: [Expr] -> [Branch] -> Chk () chkBranches scrutinees branches = do whichBorrowed <- mapM chkScrutinee scrutinees outs <- mapM (extractOutput . chkBranch whichBorrowed) branches - writeOutput =<< joinContexts outs + writeOutput =<< joinContexts (map branchPatterns branches) outs where fromVar (Var tname _) = Just tname fromVar _ = Nothing @@ -176,8 +176,12 @@ bindPattern (PatLit _) out = pure out bindPattern PatWild out = pure out chkApp :: Expr -> [Expr] -> Chk () -chkApp (TypeLam _ fn) args = chkApp fn args +chkApp (TypeLam _ fn) args = chkApp fn args -- ignore type machinery chkApp (TypeApp fn _) args = chkApp fn args +chkApp (App (TypeApp (Var openName _) _) [fn]) args | getName openName == nameEffectOpen + = chkApp fn args +chkApp (Var errorPattern _) args | getName errorPattern == namePatternMatchError + = pure () -- we do not care about the strings allocated to throw an exception chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) withNonTailCtx $ mapM_ chkArg $ zipDefault Own bs args @@ -197,7 +201,7 @@ chkApp fn args -- local function _ -> pure False unless isBapp $ do requireCapability HasDealloc $ \ppenv -> Just $ - text "Owned calls to functions require deallocation." + cat [text "Owned calls to functions require deallocation: ", prettyExpr ppenv fn ] chkExpr fn chkArg :: (ParamInfo, Expr) -> Chk () @@ -237,11 +241,14 @@ chkAllocation cname repr -- Only total/empty effects or divergence chkEffect :: Tau -> Chk () chkEffect tp - = if isFBIP then pure () else - unhandled $ text "Algebraic effects other than div are not FBIP." + = if isFBIPExtend tp then pure () else + unhandled $ text "Algebraic effects other than are not FBIP." where - isFBIP = case expandSyn tp of - TCon tc -> typeConName tc `elem` [nameEffectEmpty,nameTpDiv] + isFBIPExtend tp = case extractEffectExtend tp of + (taus, tau) -> all isFBIP taus + isFBIP tp = case expandSyn tp of + TCon tc -> typeConName tc `elem` [nameEffectEmpty,nameTpDiv,nameTpPartial] + TApp tc1 [TCon (TypeCon nm _)] -> tc1 == tconHandled && nm == nameTpPartial _ -> False {-------------------------------------------------------------------------- @@ -276,6 +283,18 @@ instance Semigroup Output where instance Monoid Output where mempty = Output M.empty M.empty +prettyGammaNm :: Pretty.Env -> Output -> Doc +prettyGammaNm ppenv (Output nm dia) + = tupled $ map + (\(nm, cnt) -> cat [ppName ppenv nm, text "/", pretty cnt]) + (M.toList nm) + +prettyGammaDia :: Pretty.Env -> Output -> Doc +prettyGammaDia ppenv (Output nm dia) + = tupled $ concatMap + (\(sz, cs) -> map (\c -> cat [ppName ppenv (getName c), text "/", pretty (sz `div` 8)]) cs) + (M.toList dia) + data Result a = Ok a Output [Doc] runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Chk a -> (a,[Doc]) @@ -378,7 +397,7 @@ markBorrowed nm info markSeen nm info when (infoIsRefCounted info) $ requireCapability HasDealloc $ \ppenv -> Just $ - cat [text "Last use of variable is borrowed (this requires deallocation): ", ppName ppenv (getName nm)] + cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] getAllocation :: TName -> Int -> Chk () getAllocation nm size @@ -389,13 +408,13 @@ provideToken debugName size out = do requireCapability HasDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in if null fittingAllocs then Just $ - cat [text "Unused reuse token requiring deallocation provided by ", ppName ppenv (getName debugName)] + cat [text "Unused reuse token provided by ", ppName ppenv (getName debugName)] else Nothing pure $ out { gammaDia = M.adjust tail size (gammaDia out) } -joinContexts :: [Output] -> Chk Output -joinContexts [] = pure mempty -joinContexts cs +joinContexts :: [[Pattern]] -> [Output] -> Chk Output +joinContexts _ [] = pure mempty +joinContexts pats cs = do let unionNm = foldl1' (M.unionWith max) (map gammaNm cs) let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs) requireCapability HasDealloc $ \ppenv -> @@ -403,16 +422,25 @@ joinContexts cs let interDia = foldl1' (M.intersectionWith chooseShorter) (map gammaDia cs) in if interNm /= unionNm then Just $ - cat [text "Not all branches use the same variables (this requires deallocation)."] + vcat $ text "Not all branches use the same variables:" + : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs else if interDia /= unionDia then Just $ - cat [text "Not all branches use the same reuse tokens (this requires deallocation)."] + vcat $ text "Not all branches use the same reuse tokens:" + : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaDia ppenv out]) pats cs else Nothing pure (Output unionNm unionDia) where chooseLonger a b = if length a >= length b then a else b chooseShorter a b = if length a <= length b then a else b + prettyPat ppenv (PatCon nm [] _ _ _ _ _ _) = ppName ppenv (getName nm) + prettyPat ppenv (PatCon nm pats _ _ _ _ _ _) = ppName ppenv (getName nm) <.> tupled (map (prettyPat ppenv) pats) + prettyPat ppenv (PatVar nm PatWild) = ppName ppenv (getName nm) + prettyPat ppenv (PatVar nm pat) = cat [ppName ppenv (getName nm), text " as ", prettyPat ppenv pat] + prettyPat ppenv (PatLit l) = text $ show l + prettyPat ppenv PatWild = text "_" + bindName :: TName -> Output -> Chk Output bindName nm out = do newtypes <- getNewtypes @@ -425,7 +453,7 @@ bindName nm out Just n -> do when (n > 1) $ requireCapability HasAlloc $ \ppenv -> Just $ - cat [text "Variable used multiple times (this can lead to allocation later): ", ppName ppenv (getName nm)] + cat [text "Variable used multiple times: ", ppName ppenv (getName nm)] pure out pure (out { gammaNm = M.delete (getName nm) (gammaNm out) }) From ecdff2f3540c829a03bf6c988538a356bba72da7 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Tue, 14 Feb 2023 15:52:08 +0000 Subject: [PATCH 126/233] Improve match! rules in FBIP analysis --- src/Backend/C/Parc.hs | 2 +- src/Core/CheckFBIP.hs | 156 ++++++++++++++++++++++++++++-------------- 2 files changed, 105 insertions(+), 53 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index cc9eca037..a7a0264eb 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -20,7 +20,7 @@ Notes: the same in a scope. ----------------------------------------------------------------------------} -module Backend.C.Parc ( parcCore ) where +module Backend.C.Parc ( parcCore, getDataDef' ) where import Lib.Trace (trace) import Control.Monad diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index f2a0038b0..3ef2259c2 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -43,8 +43,9 @@ import qualified Core.Core as Core import Core.Pretty import Core.CoreVar import Core.Borrowed -import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial) +import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) import Backend.C.ParcReuse (constructorSizeOf,getConSize) +import Backend.C.Parc (getDataDef') trace s x = Lib.Trace.trace s @@ -87,7 +88,7 @@ chkTopLevelExpr (DefFun bs) (Lam pars eff body) let opars = map snd $ filter ((==Own) . fst) $ zipDefault Own bs pars withBorrowed (S.fromList $ map getName bpars) $ do out <- extractOutput $ chkExpr body - writeOutput =<< foldM (flip bindName) out opars + writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out opars chkTopLevelExpr def (TypeLam _ body) = chkTopLevelExpr def body chkTopLevelExpr def (TypeApp body _) @@ -104,17 +105,17 @@ chkExpr expr requireCapability HasAlloc $ \ppenv -> Just $ text "Lambdas are always allocated." out <- extractOutput $ chkExpr body - writeOutput =<< foldM (flip bindName) out pars - + writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out pars + App fn args -> chkApp fn args Var tname info -> markSeen tname info Let [] body -> chkExpr body Let (DefNonRec def:dgs) body -> do out <- extractOutput $ chkExpr (Let dgs body) - gamma2 <- bindName (defTName def) out + gamma2 <- bindName (defTName def) Nothing out writeOutput gamma2 - withBorrowed (M.keysSet $ gammaNm gamma2) $ + withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ withNonTailCtx $ chkExpr $ defExpr def Let _ _ -> unhandled $ text "FBIP check can not handle recursive let bindings." @@ -134,8 +135,9 @@ chkModCons args chkBranches :: [Expr] -> [Branch] -> Chk () chkBranches scrutinees branches = do whichBorrowed <- mapM chkScrutinee scrutinees - outs <- mapM (extractOutput . chkBranch whichBorrowed) branches - writeOutput =<< joinContexts (map branchPatterns branches) outs + let branches' = filter (not . isPatternMatchError) branches + outs <- mapM (extractOutput . chkBranch whichBorrowed) branches' + writeOutput =<< joinContexts (map branchPatterns branches') outs where fromVar (Var tname _) = Just tname fromVar _ = Nothing @@ -160,18 +162,32 @@ chkBranch whichBorrowed (Branch pats guards) chkGuard :: Guard -> Chk () chkGuard (Guard test expr) = do out <- extractOutput $ chkExpr expr - withBorrowed (M.keysSet $ gammaNm out) $ + withBorrowed (S.map getName $ M.keysSet $ gammaNm out) $ withNonTailCtx $ chkExpr test writeOutput out +-- | We ignore default branches that create a pattern match error +isPatternMatchError :: Branch -> Bool +isPatternMatchError (Branch pats [Guard (Con gname _) (App (TypeApp (Var (TName fnname _) _) _) _)]) + | all isPatWild pats && getName gname == nameTrue && fnname == namePatternMatchError = True + where isPatWild PatWild = True; isPatWild _ = False +isPatternMatchError _ = False + bindPattern :: Pattern -> Output -> Chk Output bindPattern (PatCon cname pats repr _ _ _ _ _) out = do newtypes <- getNewtypes platform <- getPlatform let (size,_) = constructorSizeOf platform newtypes cname repr - bindAllocation size <$> foldM (flip bindPattern) out pats -bindPattern (PatVar tname pat) out - = bindName tname =<< bindPattern pat out + provideToken cname size =<< foldM (flip bindPattern) out pats +bindPattern (PatVar tname (PatCon cname pats repr _ _ _ _ _)) out + = do newtypes <- getNewtypes + platform <- getPlatform + let (size,_) = constructorSizeOf platform newtypes cname repr + bindName tname (Just size) =<< foldM (flip bindPattern) out pats +bindPattern (PatVar tname PatWild) out + = bindName tname Nothing out +bindPattern (PatVar tname pat) out -- Else, don't bind the name. + = bindPattern pat out -- The end of the analysis fails if the name is actually used. bindPattern (PatLit _) out = pure out bindPattern PatWild out = pure out @@ -180,8 +196,9 @@ chkApp (TypeLam _ fn) args = chkApp fn args -- ignore type machinery chkApp (TypeApp fn _) args = chkApp fn args chkApp (App (TypeApp (Var openName _) _) [fn]) args | getName openName == nameEffectOpen = chkApp fn args -chkApp (Var errorPattern _) args | getName errorPattern == namePatternMatchError - = pure () -- we do not care about the strings allocated to throw an exception +chkApp (Con cname repr) args -- try reuse + = do chkModCons args + chkAllocation cname repr chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) withNonTailCtx $ mapM_ chkArg $ zipDefault Own bs args @@ -191,9 +208,6 @@ chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function if getName tname `elem` defGroupNames input then Just $ text "Non-tail call to (mutually) recursive function: " else Nothing -chkApp (Con cname repr) args -- try reuse - = do chkModCons args - chkAllocation cname repr chkApp fn args -- local function = do withNonTailCtx $ mapM_ chkExpr args isBapp <- case fn of -- does the bapp rule apply? @@ -248,7 +262,7 @@ chkEffect tp (taus, tau) -> all isFBIP taus isFBIP tp = case expandSyn tp of TCon tc -> typeConName tc `elem` [nameEffectEmpty,nameTpDiv,nameTpPartial] - TApp tc1 [TCon (TypeCon nm _)] -> tc1 == tconHandled && nm == nameTpPartial + TApp tc1 [TCon (TypeCon nm _)] -> tc1 == tconHandled && nm == nameTpPartial _ -> False {-------------------------------------------------------------------------- @@ -274,7 +288,7 @@ data Input = Input{ delta :: S.Set Name, defGroupNames :: [Name], isTailContext :: Bool } -data Output = Output{ gammaNm :: M.Map Name Int, +data Output = Output{ gammaNm :: M.Map TName Int, gammaDia :: M.Map Int [TName] } instance Semigroup Output where @@ -286,7 +300,7 @@ instance Monoid Output where prettyGammaNm :: Pretty.Env -> Output -> Doc prettyGammaNm ppenv (Output nm dia) = tupled $ map - (\(nm, cnt) -> cat [ppName ppenv nm, text "/", pretty cnt]) + (\(nm, cnt) -> cat [ppName ppenv (getName nm), text "/", pretty cnt]) (M.toList nm) prettyGammaDia :: Pretty.Env -> Output -> Doc @@ -384,10 +398,11 @@ isBorrowed nm markSeen :: TName -> VarInfo -> Chk () markSeen tname info | infoIsRefCounted info -- is locally defined? = do b <- isBorrowed tname - if b + isHeapValue <- needsDupDrop (tnameType tname) + when isHeapValue $ if b then requireCapability HasAlloc $ \ppenv -> Just $ cat [text "Borrowed value used as owned (can cause allocations later): ", ppName ppenv (getName tname)] - else writeOutput (Output (M.singleton (getName tname) 1) M.empty) + else writeOutput (Output (M.singleton tname 1) M.empty) markSeen tname info = chkWrap tname info -- wrap rule markBorrowed :: TName -> VarInfo -> Chk () @@ -400,39 +415,49 @@ markBorrowed nm info cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] getAllocation :: TName -> Int -> Chk () +getAllocation nm 0 = pure () getAllocation nm size = writeOutput (Output mempty (M.singleton size [nm])) provideToken :: TName -> Int -> Output -> Chk Output +provideToken _ 0 out = pure out provideToken debugName size out = do requireCapability HasDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in if null fittingAllocs then Just $ - cat [text "Unused reuse token provided by ", ppName ppenv (getName debugName)] + cat [text "Unused reuse token provided by ", ppName ppenv (getName debugName), text $ "/" ++ show (size `div` 8)] else Nothing - pure $ out { gammaDia = M.adjust tail size (gammaDia out) } + pure $ out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } joinContexts :: [[Pattern]] -> [Output] -> Chk Output joinContexts _ [] = pure mempty joinContexts pats cs = do let unionNm = foldl1' (M.unionWith max) (map gammaNm cs) - let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs) + (noDealloc, cs') <- fmap unzip $ forM cs $ \c -> do + let nm = M.difference unionNm (gammaNm c) + (allReusable, c') <- foldM tryReuse (True, c) (map fst $ M.toList nm) + pure (allReusable, c') + unless (and noDealloc) $ do + requireCapability HasDealloc $ \ppenv -> Just $ + vcat $ text "Not all branches use the same variables:" + : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs + let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs') requireCapability HasDealloc $ \ppenv -> - let interNm = foldl1' (M.intersectionWith min) (map gammaNm cs) in - let interDia = foldl1' (M.intersectionWith chooseShorter) (map gammaDia cs) in - if interNm /= unionNm - then Just $ - vcat $ text "Not all branches use the same variables:" - : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs - else if interDia /= unionDia - then Just $ - vcat $ text "Not all branches use the same reuse tokens:" - : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaDia ppenv out]) pats cs - else Nothing + let noDealloc = all (M.null . M.differenceWith lengthDifferent unionDia . gammaDia) cs' + in if noDealloc then Nothing else Just $ + vcat $ text "Not all branches use the same reuse tokens:" + : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaDia ppenv out]) pats cs' pure (Output unionNm unionDia) where chooseLonger a b = if length a >= length b then a else b - chooseShorter a b = if length a <= length b then a else b + lengthDifferent a b = if length a /= length b then Just b else Nothing + + tryReuse (allReusable, out) tname + = do mOut <- tryDropReuse tname out + isHeapVal <- needsDupDrop (tnameType tname) + pure $ case mOut of + Nothing -> (allReusable && not isHeapVal, out) + Just out -> (allReusable, out) prettyPat ppenv (PatCon nm [] _ _ _ _ _ _) = ppName ppenv (getName nm) prettyPat ppenv (PatCon nm pats _ _ _ _ _ _) = ppName ppenv (getName nm) <.> tupled (map (prettyPat ppenv) pats) @@ -441,36 +466,48 @@ joinContexts pats cs prettyPat ppenv (PatLit l) = text $ show l prettyPat ppenv PatWild = text "_" -bindName :: TName -> Output -> Chk Output -bindName nm out +tryDropReuse :: TName -> Output -> Chk (Maybe Output) +tryDropReuse nm out + = do newtypes <- getNewtypes + platform <- getPlatform + case getConSize newtypes platform (tnameType nm) of + Nothing -> pure Nothing + Just (sz, _) -> Just <$> provideToken nm sz out + +bindName :: TName -> Maybe Int -> Output -> Chk Output +bindName nm msize out = do newtypes <- getNewtypes platform <- getPlatform - out <- case M.lookup (getName nm) (gammaNm out) of + out <- case M.lookup nm (gammaNm out) of Nothing -- unused, so available for drop-guided reuse! - -> case getConSize newtypes platform (tnameType nm) of - Nothing -> pure out - Just (sz, _) -> pure $ bindAllocation sz out + -> do mOut <- tryDropReuse nm out + case (msize, mOut) of + (Just sz, _) -> provideToken nm sz out + (_, Just out) -> pure out + (Nothing, Nothing) -> do + isHeapValue <- needsDupDrop (tnameType nm) + when isHeapValue $ + requireCapability HasDealloc $ \ppenv -> Just $ + cat [text "Variable unused: ", ppName ppenv (getName nm)] + pure out Just n - -> do when (n > 1) $ + -> do isHeapVal <- needsDupDrop (tnameType nm) + when (n > 1 && isHeapVal) $ requireCapability HasAlloc $ \ppenv -> Just $ cat [text "Variable used multiple times: ", ppName ppenv (getName nm)] - pure out - pure (out { gammaNm = M.delete (getName nm) (gammaNm out) }) - -bindAllocation :: Int -> Output -> Output -bindAllocation size out - = out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } + pure out + pure (out { gammaNm = M.delete nm (gammaNm out) }) checkOutputEmpty :: Output -> Chk () checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ text $ "FBIP analysis didn't bind a name (this is a bug!): " ++ show nm + -> emitWarning $ text $ "FBIP analysis failed as it didn't bind a name: " ++ show nm case M.maxViewWithKey $ gammaDia out of Just ((sz, c:_), _) | sz > 0 -> requireCapability HasAlloc $ \ppenv -> Just $ - cat [text "Unreused constructor: ", ppName ppenv (getName c) ] + cat [text "Unreused constructor: ", ppName ppenv (getName c), text $ "/" ++ show (sz `div` 8) ] _ -> pure () zipDefault :: a -> [a] -> [b] -> [(a, b)] @@ -478,6 +515,21 @@ zipDefault x [] (b:bs) = (x, b) : zipDefault x [] bs zipDefault x (a:as) (b:bs) = (a, b) : zipDefault x as bs zipDefault x _ [] = [] +-- value types with reference fields still need a drop +needsDupDrop :: Type -> Chk Bool +needsDupDrop tp + = do dd <- getDataDef tp + return $ case dd of + (DataDefValue _ 0) -> False + _ -> True + +getDataDef :: Type -> Chk DataDef +getDataDef tp + = do newtypes <- getNewtypes + return (case getDataDef' newtypes tp of + Just dd -> dd + Nothing -> DataDefNormal) + getNewtypes :: Chk Newtypes getNewtypes = newtypes <$> getEnv From a152d7d71ff38eae4b6fff0713348bd0f6d55b78 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Tue, 14 Feb 2023 19:09:27 +0000 Subject: [PATCH 127/233] Disable picking reuse tokens which can prevent reuse accidentally --- src/Backend/C/ParcReuse.hs | 5 +++-- src/Core/CheckFBIP.hs | 16 ++++++++++------ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index ab684882f..5d52e97c5 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -273,8 +273,9 @@ ruTryReuseCon cname repr conApp available <- getAvailable -- ruTrace $ "try reuse: " ++ show (getName cname) ++ ": " ++ show size case M.lookup size available of - Just (rinfo0:rinfos0) - -> do let (rinfo,rinfos) = pick cname rinfo0 rinfos0 + Just (rinfo:rinfos) + -> do -- let (rinfo,rinfos) = pick cname rinfo0 rinfos0 + -- Picking can prevent reuse in FIP programs, disabled for now. setAvailable (M.insert size rinfos available) markReused (reuseName rinfo) return (genAllocAt rinfo conApp) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 3ef2259c2..36c68fb32 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -148,7 +148,7 @@ chkScrutinee expr@(Var tname info) unless b $ markSeen tname info pure (if b then Borrow else Own) chkScrutinee expr - = do chkExpr expr + = do withNonTailCtx $ chkExpr expr pure Own chkBranch :: [ParamInfo] -> Branch -> Chk () @@ -206,7 +206,7 @@ chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function unless (isTailContext input) $ requireCapability HasStack $ \ppenv -> if getName tname `elem` defGroupNames input - then Just $ text "Non-tail call to (mutually) recursive function: " + then Just $ cat [text "Non-tail call to (mutually) recursive function: ", ppName ppenv (getName tname)] else Nothing chkApp fn args -- local function = do withNonTailCtx $ mapM_ chkExpr args @@ -303,10 +303,14 @@ prettyGammaNm ppenv (Output nm dia) (\(nm, cnt) -> cat [ppName ppenv (getName nm), text "/", pretty cnt]) (M.toList nm) +prettyCon :: Pretty.Env -> TName -> Int -> Doc +prettyCon ppenv tname sz + = cat [ppName ppenv (getName tname), text "/", pretty (sz `div` 8)] + prettyGammaDia :: Pretty.Env -> Output -> Doc prettyGammaDia ppenv (Output nm dia) = tupled $ concatMap - (\(sz, cs) -> map (\c -> cat [ppName ppenv (getName c), text "/", pretty (sz `div` 8)]) cs) + (\(sz, cs) -> map (\c -> prettyCon ppenv c sz) cs) (M.toList dia) data Result a = Ok a Output [Doc] @@ -425,7 +429,7 @@ provideToken debugName size out = do requireCapability HasDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in if null fittingAllocs then Just $ - cat [text "Unused reuse token provided by ", ppName ppenv (getName debugName), text $ "/" ++ show (size `div` 8)] + cat [text "Unused reuse token provided by ", prettyCon ppenv debugName size] else Nothing pure $ out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } @@ -443,7 +447,7 @@ joinContexts pats cs : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs') requireCapability HasDealloc $ \ppenv -> - let noDealloc = all (M.null . M.differenceWith lengthDifferent unionDia . gammaDia) cs' + let noDealloc = all (M.null . M.filter (not . null) . M.differenceWith lengthDifferent unionDia . gammaDia) cs' in if noDealloc then Nothing else Just $ vcat $ text "Not all branches use the same reuse tokens:" : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaDia ppenv out]) pats cs' @@ -507,7 +511,7 @@ checkOutputEmpty out case M.maxViewWithKey $ gammaDia out of Just ((sz, c:_), _) | sz > 0 -> requireCapability HasAlloc $ \ppenv -> Just $ - cat [text "Unreused constructor: ", ppName ppenv (getName c), text $ "/" ++ show (sz `div` 8) ] + cat [text "Unreused constructor: ", prettyCon ppenv c sz] _ -> pure () zipDefault :: a -> [a] -> [b] -> [(a, b)] From c0589a02134bb03cddac5ed40c1eec1d866e9c6e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 14 Feb 2023 17:51:40 -0800 Subject: [PATCH 128/233] fix constructorSizeOf and rename getConSize to getDataTypeSize --- src/Backend/C/Parc.hs | 12 ++++---- src/Backend/C/ParcReuse.hs | 58 +++++++++++++++++++++++++++----------- src/Core/CheckFBIP.hs | 41 ++++++++++++++++----------- 3 files changed, 72 insertions(+), 39 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index a7a0264eb..41218a6ab 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -461,9 +461,9 @@ inferShapes scrutineeNames pats where shapesOf :: TName -> Pattern -> Parc ShapeMap shapesOf parent pat = case pat of - PatCon{patConPatterns,patConName,patConRepr} + PatCon{patConPatterns,patConName,patConRepr,patConInfo} -> do ms <- mapM shapesChild patConPatterns - scan <- getConstructorScanFields patConName patConRepr + scan <- getConstructorScanFields patConInfo patConRepr let m = M.unionsWith noDup ms shape = ShapeInfo (Just (tnamesFromList (map patName patConPatterns))) (Just (patConRepr,getName patConName)) (Just scan) @@ -691,7 +691,7 @@ genDupDrop isDup tname mbConRepr mbScanCount in case mbDi of Just di -> case (dataInfoDef di, dataInfoConstrs di, snd (getDataRepr di)) of (DataDefNormal, [conInfo], [conRepr]) -- data with just one constructor - -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr + -> do scan <- getConstructorScanFields conInfo conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) (DataDefValue _ 0, _, _) @@ -835,11 +835,11 @@ getPlatform :: Parc Platform getPlatform = platform <$> getEnv -getConstructorScanFields :: TName -> ConRepr -> Parc Int -getConstructorScanFields conName conRepr +getConstructorScanFields :: ConInfo -> ConRepr -> Parc Int +getConstructorScanFields conInfo conRepr = do platform <- getPlatform newtypes <- getNewtypes - let (size,scan) = (constructorSizeOf platform newtypes conName conRepr) + let (size,scan) = (constructorSizeOf platform newtypes conInfo conRepr) -- parcTrace $ "get size " ++ show conName ++ ": " ++ show (size,scan) ++ ", " ++ show conRepr return scan diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 5d52e97c5..b9256df30 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -13,7 +13,7 @@ module Backend.C.ParcReuse ( parcReuseCore, orderConFieldsEx, newtypesDataDefRepr, hasTagField, - constructorSizeOf, getConSize + constructorSizeOf, constructorSizeOfByName, getDataTypeSize ) where import Lib.Trace (trace) @@ -114,7 +114,7 @@ ruLam :: [TName] -> Effect -> Expr -> Reuse Expr ruLam pars eff body = fmap (Lam pars eff) $ withNone $ do forM_ pars $ \p -> do - msize <- getRuConSize (typeOf p) + msize <- getRuDataTypeSize (typeOf p) case msize of Just (size, scan) -> addDeconstructed (p, Nothing, size, scan) Nothing -> return () @@ -239,13 +239,13 @@ ruPattern varName pat@PatCon{patConName,patConPatterns,patConRepr,patTypeArgs,pa else do newtypes <- getNewtypes platform <- getPlatform -- use type scheme of con, not the instantiated type, to calculate the correct size - let (size, scan) = constructorSizeOf platform newtypes (TName (conInfoName ci) (conInfoType ci)) patConRepr + let (size, scan) = constructorSizeOf platform newtypes ci patConRepr if size > 0 then do -- ruTrace $ "add for reuse: " ++ show (getName tname) ++ ": " ++ show size return ((varName, Just pat, size, scan):reuses) else return reuses ruPattern varName _ - = do msize <- getRuConSize (typeOf varName) + = do msize <- getRuDataTypeSize (typeOf varName) case msize of Just (size, scan) -> return [(varName, Nothing, size, scan)] Nothing -> return [] @@ -267,9 +267,7 @@ ruTryReuseCon cname repr conApp | isConAsJust repr -- never try to reuse a Just ruTryReuseCon cname repr conApp | "_noreuse" `isSuffixOf` nameId (conTypeName repr) = return conApp -- special case to allow benchmarking the effect of reuse analysis ruTryReuseCon cname repr conApp - = do newtypes <- getNewtypes - platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr + = do size <- getConstructorSize cname repr available <- getAvailable -- ruTrace $ "try reuse: " ++ show (getName cname) ++ ": " ++ show size case M.lookup size available of @@ -562,6 +560,13 @@ isolateGetReused action setReused r0 return (x,r1) +getConstructorSize :: TName -> ConRepr -> Reuse Int +getConstructorSize conName conRepr + = do newtypes <- getNewtypes + platform <- getPlatform + let (size,_) = constructorSizeOfByName platform newtypes (getName conName) conRepr + return size + -------------------------------------------------------------------------- -- Tracing -------------------------------------------------------------------------- @@ -579,16 +584,16 @@ ruTrace msg ---------------- -getRuConSize :: Type -> Reuse (Maybe (Int, Int)) -getRuConSize dataType +getRuDataTypeSize :: Type -> Reuse (Maybe (Int, Int)) +getRuDataTypeSize dataType = do newtypes <- getNewtypes platform <- getPlatform - pure $ getConSize newtypes platform dataType + pure $ getDataTypeSize newtypes platform dataType -- | If all constructors of a type have the same shape, -- return the byte size and number of scan fields. -getConSize :: Newtypes -> Platform -> Type -> Maybe (Int, Int) -getConSize newtypes platform dataType +getDataTypeSize :: Newtypes -> Platform -> Type -> Maybe (Int, Int) +getDataTypeSize newtypes platform dataType = let mdataName = extractDataName dataType in if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName then Nothing else @@ -610,15 +615,34 @@ getConSize newtypes platform dataType TCon tc -> Just (typeConName tc) _ -> Nothing + + +constructorSizeOfByName :: Platform -> Newtypes -> Name -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOfByName platform newtypes conName conRepr + = -- lookup the conInfo as we need an uninstantiated type for the constructor parameters! + let dataInfo = newtypesFind (conTypeName conRepr) newtypes + in case filter (\cinfo -> conInfoName cinfo == conName) (dataInfoConstrs dataInfo) of + [conInfo] -> constructorSizeOf platform newtypes conInfo conRepr + _ -> failure ("Backend.C.ParcReuse.getConstructorSize: invalid dataInfo for " ++ show conName) + + +-- return the allocated size of a constructor. Return 0 for value types or singletons +constructorSizeOf :: Platform -> Newtypes -> ConInfo -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOf platform newtypes conInfo conRepr + = constructorSizeOfX platform newtypes (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr + -- return the allocated size of a constructor. Return 0 for value types or singletons -constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) -constructorSizeOf _ _ _ repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) +-- note: expects the general type of the constructor in TName -- not an instantiated type! +constructorSizeOfX :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOfX _ _ _ repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) = (0,0) -- special case to allow benchmarking the effect of reuse analysis -constructorSizeOf platform newtypes conName conRepr +constructorSizeOfX platform newtypes conName conRepr = let dataRepr = conDataRepr conRepr in case splitFunScheme (typeOf conName) of Just (_,_,tpars,_,_) - -> constructorSize platform newtypes dataRepr (map snd tpars) + -> let (size,scan) = constructorSize platform newtypes dataRepr (map snd tpars) + in -- trace ("constructor: " ++ show conName ++ ": size: " ++ show size ++ ", scan: " ++ show scan ++ ", " ++ show tpars) $ + (size,scan) _ -> -- trace ("constructor not a function: " ++ show conName ++ ": " ++ show (pretty (typeOf conName))) $ (0,0) @@ -639,7 +663,7 @@ constructorSize platform newtypes dataRepr paramTypes -- return the ordered fields, the byte size of the allocation, and the scan count (including tags) orderConFieldsEx :: Platform -> Newtypes -> Bool -> [(Name,Type)] -> ([(Name,Type)],Int,Int) orderConFieldsEx platform newtypes isOpen fields - = visit ([],[],[],0) fields + = visit ([],[],[],0) fields where visit (rraw, rmixed, rscan, scanCount0) [] = if (length rmixed > 1) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 36c68fb32..0c45b48c7 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -44,7 +44,7 @@ import Core.Pretty import Core.CoreVar import Core.Borrowed import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) -import Backend.C.ParcReuse (constructorSizeOf,getConSize) +import Backend.C.ParcReuse (constructorSizeOf, constructorSizeOfByName, getDataTypeSize) import Backend.C.Parc (getDataDef') trace s x = @@ -174,15 +174,11 @@ isPatternMatchError (Branch pats [Guard (Con gname _) (App (TypeApp (Var (TName isPatternMatchError _ = False bindPattern :: Pattern -> Output -> Chk Output -bindPattern (PatCon cname pats repr _ _ _ _ _) out - = do newtypes <- getNewtypes - platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr +bindPattern (PatCon cname pats crepr _ _ _ conInfo _) out + = do size <- getConstructorSize conInfo crepr provideToken cname size =<< foldM (flip bindPattern) out pats -bindPattern (PatVar tname (PatCon cname pats repr _ _ _ _ _)) out - = do newtypes <- getNewtypes - platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr +bindPattern (PatVar tname (PatCon cname pats crepr _ _ _ conInfo _)) out + = do size <- getConstructorSize conInfo crepr bindName tname (Just size) =<< foldM (flip bindPattern) out pats bindPattern (PatVar tname PatWild) out = bindName tname Nothing out @@ -246,10 +242,8 @@ chkAllocation cname repr | isConAsJust repr = pure () chkAllocation cname repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) = requireCapability HasAlloc $ \ppenv -> Just $ cat [text "Types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] -chkAllocation cname repr - = do newtypes <- getNewtypes - platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr +chkAllocation cname crepr + = do size <- getConstructorSizeByName cname crepr getAllocation cname size -- Only total/empty effects or divergence @@ -305,7 +299,7 @@ prettyGammaNm ppenv (Output nm dia) prettyCon :: Pretty.Env -> TName -> Int -> Doc prettyCon ppenv tname sz - = cat [ppName ppenv (getName tname), text "/", pretty (sz `div` 8)] + = cat [ppName ppenv (getName tname), text "/", pretty (sz {-`div` 8-})] prettyGammaDia :: Pretty.Env -> Output -> Doc prettyGammaDia ppenv (Output nm dia) @@ -474,7 +468,7 @@ tryDropReuse :: TName -> Output -> Chk (Maybe Output) tryDropReuse nm out = do newtypes <- getNewtypes platform <- getPlatform - case getConSize newtypes platform (tnameType nm) of + case getDataTypeSize newtypes platform (tnameType nm) of Nothing -> pure Nothing Just (sz, _) -> Just <$> provideToken nm sz out @@ -579,4 +573,19 @@ emitWarning :: Doc -> Chk () emitWarning doc = do names <- currentDefNames let fdoc = text (show names) <.> colon <+> doc - emitDoc fdoc \ No newline at end of file + emitDoc fdoc + +getConstructorSizeByName :: TName -> ConRepr -> Chk Int +getConstructorSizeByName conName conRepr + = do platform <- getPlatform + newtypes <- getNewtypes + let (size,_) = constructorSizeOfByName platform newtypes (getName conName) conRepr + return size + +getConstructorSize :: ConInfo -> ConRepr -> Chk Int +getConstructorSize conInfo conRepr + = do platform <- getPlatform + newtypes <- getNewtypes + let (size,_) = constructorSizeOf platform newtypes conInfo conRepr + return size + \ No newline at end of file From b1ac9e2d53a29e035b024f67f4e3634126da1e91 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 15 Feb 2023 13:01:10 -0800 Subject: [PATCH 129/233] WIP: temporary fix for space leak on borrowed boxed matches --- src/Backend/C/FromCore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 8f6fa49d5..5ba9f9e1d 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1533,7 +1533,7 @@ genPatternTest doTest eagerPatBind (exprDoc,pattern) -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon -> do local <- newVarName "unbox" - let assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] + let assign = [ppType tres <+> ppDefName local <+> text "=" <+> {- genDupCall tres -} exprDoc <.> semi] unbox = genBoxCall "unbox" False targ (ppDefName local) -- assign = [] -- unbox = genBoxCall "unbox" True {- borrowing -} targ exprDoc From 05e0e9451fd6ebdba0cc7959b48af9e33f9c3b64 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 15 Feb 2023 13:04:56 -0800 Subject: [PATCH 130/233] WIP: undo temporary fix as it leads to segfaults --- src/Backend/C/FromCore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 5ba9f9e1d..8f6fa49d5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1533,7 +1533,7 @@ genPatternTest doTest eagerPatBind (exprDoc,pattern) -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon -> do local <- newVarName "unbox" - let assign = [ppType tres <+> ppDefName local <+> text "=" <+> {- genDupCall tres -} exprDoc <.> semi] + let assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] unbox = genBoxCall "unbox" False targ (ppDefName local) -- assign = [] -- unbox = genBoxCall "unbox" True {- borrowing -} targ exprDoc From 40f09878ced8adfc9337f51a89e08e9ef725968b Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 16 Feb 2023 13:01:57 -0800 Subject: [PATCH 131/233] fix leak in valuetype pattern matching; add borrow parameter to unbox calls --- kklib/include/kklib.h | 2 +- kklib/include/kklib/box.h | 70 +++++++++++++++++++++-------------- kklib/include/kklib/maybe.h | 9 +++-- kklib/include/kklib/string.h | 4 +- kklib/src/box.c | 72 +++++++++++++++++++----------------- kklib/src/string.c | 6 +-- kklib/src/thread.c | 8 ++-- kklib/test/main.c | 4 +- lib/std/core/core-inline.c | 4 +- lib/std/core/hnd-inline.c | 4 +- lib/std/core/types.kk | 2 + lib/std/text/regex-inline.c | 4 +- lib/std/text/regex.kk | 2 +- src/Backend/C/FromCore.hs | 62 ++++++++++++++++++++----------- 14 files changed, 148 insertions(+), 105 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 97881c8ea..7e486bd96 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 101 // modify on changes to trigger recompilation +#define KKLIB_BUILD 102 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index c391751ff..f880faea5 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -170,22 +170,38 @@ static inline void kk_box_drop(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_ptr(b)) { kk_block_drop(kk_ptr_unbox(b, ctx), ctx); } } +/*---------------------------------------------------------------- + Borrowing for value types in matches +----------------------------------------------------------------*/ + +typedef enum kk_borrow_e { + KK_OWNED = 0, + KK_BORROWED +} kk_borrow_t; + +static inline bool kk_is_owned(kk_borrow_t borrow) { + return (borrow != KK_BORROWED); +} +static inline bool kk_is_borrowed(kk_borrow_t borrow) { + return (borrow == KK_BORROWED); +} + /*---------------------------------------------------------------- Integers & Floats ----------------------------------------------------------------*/ -kk_decl_export intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx); +kk_decl_export intptr_t kk_intptr_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx); +kk_decl_export kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx); -kk_decl_export kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx); #if (KK_INTF_SIZE <= 8) -kk_decl_export int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx); +kk_decl_export int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx); #else -static inline int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); +static inline int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); kk_intf_t i = kk_intf_unbox(v, ctx); kk_assert_internal((i >= INT64_MIN && i <= INT64_MAX) || kk_box_is_any(v)); return (int64_t)i; @@ -197,11 +213,11 @@ static inline kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { #endif #if (KK_INTF_SIZE<=4) -kk_decl_export int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx); +kk_decl_export int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx); #else -static inline int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); +static inline int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT32_MIN && i <= INT32_MAX) || kk_box_is_any(v)); return (int32_t)(i); @@ -214,11 +230,11 @@ static inline kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { #endif #if (KK_INTF_SIZE<=2) -kk_decl_export int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx); +kk_decl_export int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx); #else -static inline int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); +static inline int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT16_MIN && i <= INT16_MAX) || kk_box_is_any(v)); return (int16_t)(i); @@ -231,10 +247,10 @@ static inline kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { #if (KK_INTF_SIZE == 8) && KK_BOX_DOUBLE64 kk_decl_export kk_box_t kk_double_box(double d, kk_context_t* ctx); -kk_decl_export double kk_double_unbox(kk_box_t b, kk_context_t* ctx); +kk_decl_export double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); #else -static inline double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { - int64_t i = kk_int64_unbox(b, ctx); +static inline double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + int64_t i = kk_int64_unbox(b, borrow, ctx); return kk_bits_to_double((uint64_t)i); } static inline kk_box_t kk_double_box(double d, kk_context_t* ctx) { @@ -244,11 +260,11 @@ static inline kk_box_t kk_double_box(double d, kk_context_t* ctx) { #endif #if (KK_INTF_SIZE == 4) -kk_decl_export float kk_float_unbox(kk_box_t b, kk_context_t* ctx); +kk_decl_export float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_float_box(float f, kk_context_t* ctx); #else -static inline float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { - int32_t i = kk_int32_unbox(b, ctx); +static inline float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + int32_t i = kk_int32_unbox(b, borrow, ctx); return kk_bits_to_float((uint32_t)i); } static inline kk_box_t kk_float_box(float f, kk_context_t* ctx) { @@ -273,8 +289,8 @@ static inline kk_box_t kk_size_box(size_t i, kk_context_t* ctx) { return kk_ssize_box((kk_ssize_t)i, ctx); } -static inline size_t kk_size_unbox(kk_box_t b, kk_context_t* ctx) { - return (size_t)kk_ssize_unbox(b, ctx); +static inline size_t kk_size_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return (size_t)kk_ssize_unbox(b, borrow, ctx); } static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag, kk_context_t* ctx ) { @@ -335,21 +351,21 @@ typedef struct kk_boxed_value_s { } * kk_boxed_value_t; -kk_decl_export void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx); +kk_decl_export void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_borrow_t borrow, kk_context_t* ctx); -#define kk_valuetype_unbox(tp,x,box,ctx) \ +#define kk_valuetype_unbox(tp,x,box,borrow,ctx) \ do { \ if kk_unlikely(kk_box_is_any(box)) { \ - kk_valuetype_unbox_from_any((kk_box_t*)&x, sizeof(tp), box, ctx); \ + kk_valuetype_unbox_from_any((kk_box_t*)&x, sizeof(tp), box, borrow, ctx); \ } \ else { \ kk_boxed_value_t p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ - /* if (ctx!=NULL) { */ \ + if (kk_is_owned(borrow)) { \ if (kk_base_type_is_unique(p)) { kk_base_type_free(p,ctx); } \ else { tp##_dup(x,ctx); kk_base_type_decref(p,ctx); } \ - /* } */ \ - }\ + } \ + } \ } while(0) @@ -380,9 +396,9 @@ typedef struct kk_cptr_raw_s { } *kk_cptr_raw_t; kk_decl_export kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx); +kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_cptr_box(void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_unbox(kk_box_t b, kk_context_t* ctx); +kk_decl_export void* kk_cptr_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); // C function pointers typedef void (*kk_cfun_ptr_t)(void); diff --git a/kklib/include/kklib/maybe.h b/kklib/include/kklib/maybe.h index ac515f4de..a10fd325c 100644 --- a/kklib/include/kklib/maybe.h +++ b/kklib/include/kklib/maybe.h @@ -42,16 +42,17 @@ typedef struct kk_just_s { kk_box_t value; } kk_just_t; -kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_context_t* ctx); +kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_borrow_t borrow, kk_context_t* ctx); -static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_context_t* ctx) { +static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { if (kk_box_is_ptr(b)) { kk_block_t* bl = kk_ptr_unbox(b, ctx); if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { - return kk_unbox_Just_block(bl, ctx); + return kk_unbox_Just_block(bl, borrow, ctx); } } - // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b + // if borrowing we should not change refcounts, + // and if not borrowing, we consume the b return b; } diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index 90691002d..5055092ca 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -160,8 +160,8 @@ typedef int32_t kk_char_t; #define kk_char_replacement KK_I32(0xFFFD) -static inline kk_char_t kk_char_unbox(kk_box_t b, kk_context_t* ctx) { - return (kk_char_t)kk_int32_unbox(b, ctx); +static inline kk_char_t kk_char_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return (kk_char_t)kk_int32_unbox(b, borrow, ctx); } static inline kk_box_t kk_char_box(kk_char_t c, kk_context_t* ctx) { diff --git a/kklib/src/box.c b/kklib/src/box.c index c64597473..da9765d26 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -11,12 +11,14 @@ Value type boxing ----------------------------------------------------------------*/ -void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_context_t* ctx) { +void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_borrow_t borrow, kk_context_t* ctx) { const size_t max_scan_fsize = size / sizeof(kk_box_t); for (size_t i = 0; i < max_scan_fsize; i++) { p[i] = kk_box_any(ctx); } - kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); + if (kk_is_owned(borrow)) { + kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); + } } /*---------------------------------------------------------------- @@ -28,7 +30,7 @@ typedef struct kk_boxed_intptr_s { intptr_t value; } *boxed_intptr_t; -intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { +intptr_t kk_intptr_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (intptr_t)i; @@ -37,7 +39,7 @@ intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INTPTR) || kk_box_is_any(v)); boxed_intptr_t bi = kk_block_assert(boxed_intptr_t, kk_ptr_unbox(v,ctx), KK_TAG_INTPTR); intptr_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } @@ -60,7 +62,7 @@ typedef struct kk_boxed_int64_s { int64_t value; } *boxed_int64_t; -int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { +int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (int64_t)i; @@ -69,7 +71,7 @@ int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT64) || kk_box_is_any(v)); boxed_int64_t bi = kk_block_assert(boxed_int64_t, kk_ptr_unbox(v,ctx), KK_TAG_INT64); int64_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } @@ -93,7 +95,7 @@ typedef struct kk_boxed_int32_s { int32_t value; } *boxed_int32_t; -int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { +int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT32_MIN && i <= INT32_MAX) || kk_box_is_any(v)); @@ -103,7 +105,7 @@ int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT32) || kk_box_is_any(v)); boxed_int32_t bi = kk_block_assert(boxed_int32_t, kk_ptr_unbox(v,ctx), KK_TAG_INT32); int32_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } @@ -126,7 +128,7 @@ typedef struct kk_boxed_int16_s { int16_t value; } *boxed_int16_t; -int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { +int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= int16_MIN && i <= int16_MAX) || kk_box_is_any(v)); @@ -136,7 +138,7 @@ int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT16) || kk_box_is_any(v)); boxed_int16_t bi = kk_block_assert(boxed_int16_t, kk_ptr_unbox(v,ctx), KK_TAG_INT16); int16_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } @@ -157,29 +159,29 @@ kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_intptr_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_intptr_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_intptr_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 8 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int64_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int64_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int64_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 4 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int32_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int32_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int32_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 2 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int16_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int16_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int16_unbox(b, borrow, ctx); } #else #error "platform size_t must be 16, 32, 64, or 128 bits" @@ -199,9 +201,11 @@ kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx) { return kk_ptr_box(&raw->_block,ctx); } -void* kk_cptr_raw_unbox(kk_box_t b, kk_context_t* ctx) { +void* kk_cptr_raw_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_cptr_raw_t raw = kk_block_unbox_as(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); - return raw->cptr; + void* p = raw->cptr; + if (kk_is_owned(borrow)) { kk_base_type_drop(raw, ctx); } + return p; } kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { @@ -216,12 +220,12 @@ kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { } } -void* kk_cptr_unbox(kk_box_t b, kk_context_t* ctx) { +void* kk_cptr_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { if (kk_box_is_value(b)) { return (void*)((intptr_t)kk_intf_unbox(b)); } else { - return kk_cptr_raw_unbox(b,ctx); + return kk_cptr_raw_unbox(b,borrow,ctx); } } @@ -231,10 +235,10 @@ void* kk_cptr_unbox(kk_box_t b, kk_context_t* ctx) { Maybe type support ----------------------------------------------------------------*/ -kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ) { +kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_borrow_t borrow, kk_context_t* ctx ) { kk_assert_internal(kk_block_has_tag(b,KK_TAG_JUST)); kk_box_t res = kk_block_as(kk_just_t*, b)->value; - if (ctx != NULL) { + if (kk_is_owned(borrow)) { if (kk_block_is_unique(b)) { kk_block_free(b,ctx); } @@ -258,10 +262,10 @@ typedef struct kk_boxed_double_s { double value; } *kk_boxed_double_t; -static double kk_double_unbox_heap(kk_box_t b, kk_context_t* ctx) { +static double kk_double_unbox_heap(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_boxed_double_t dt = kk_block_assert(kk_boxed_double_t, kk_ptr_unbox(b,ctx), KK_TAG_DOUBLE); double d = dt->value; - if (ctx != NULL) { kk_base_type_drop(dt, ctx); } + if (kk_is_owned(borrow)) { kk_base_type_drop(dt, ctx); } return d; } @@ -286,7 +290,7 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { } } -double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { +double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); double d; if (kk_box_is_value(b)) { @@ -295,7 +299,7 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { } else { // heap allocated - d = kk_double_unbox_heap(b, ctx); + d = kk_double_unbox_heap(b, borrow, ctx); } // if (isnan(d)) { kk_debugger_break(ctx); } return d; @@ -326,7 +330,7 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { return kk_uintf_box( kk_shr64(u,1) | exp ); } -double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { +double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); if (kk_box_is_value(b)) { // expand 10-bit exponent to 11-bits again @@ -349,7 +353,7 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { } else { // heap allocated - return kk_double_unbox_heap(b, ctx); + return kk_double_unbox_heap(b, borrow, ctx); } } #endif @@ -367,10 +371,10 @@ typedef struct kk_boxed_float_s { float value; } *kk_boxed_float_t; -static float kk_float_unbox_heap(kk_box_t b, kk_context_t* ctx) { +static float kk_float_unbox_heap(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_boxed_float_t ft = kk_block_assert(kk_boxed_float_t, kk_ptr_unbox(b,ctx), KK_TAG_FLOAT); float f = ft->value; - if (ctx != NULL) { kk_base_type_drop(ft, ctx); } + if (kk_is_owned(borrow)) { kk_base_type_drop(ft, ctx); } return f; } @@ -392,7 +396,7 @@ kk_box_t kk_float_box(float f, kk_context_t* ctx) { } } -float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { +float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); float f; if (kk_box_is_value(b)) { @@ -401,7 +405,7 @@ float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { } else { // heap allocated - f = kk_float_unbox_heap(b, ctx); + f = kk_float_unbox_heap(b, borrow, ctx); } // if (isnan(f)) { kk_debugger_break(ctx); } return f; diff --git a/kklib/src/string.c b/kklib/src/string.c index 6715353fe..e0ca416ae 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -695,13 +695,13 @@ kk_string_t kk_string_from_chars(kk_vector_t v, kk_context_t* ctx) { kk_box_t* cs = kk_vector_buf_borrow(v, &n, ctx); kk_ssize_t len = 0; for (kk_ssize_t i = 0; i < n; i++) { - len += kk_utf8_len(kk_char_unbox(cs[i], ctx)); + len += kk_utf8_len(kk_char_unbox(cs[i], KK_BORROWED, ctx)); } uint8_t* p; kk_string_t s = kk_unsafe_string_alloc_buf(len + 1, &p, ctx); for (kk_ssize_t i = 0; i < n; i++) { kk_ssize_t count; - kk_utf8_write(kk_char_unbox(cs[i], ctx), p, &count); + kk_utf8_write(kk_char_unbox(cs[i], KK_BORROWED, ctx), p, &count); p += count; } kk_assert_internal(kk_string_buf_borrow(s, NULL, ctx) + n == p); @@ -959,7 +959,7 @@ kk_string_t kk_show_any(kk_box_t b, kk_context_t* ctx) { } else if (tag == KK_TAG_FUNCTION) { struct kk_function_s* fun = kk_block_assert(struct kk_function_s*, p, KK_TAG_FUNCTION); - snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun, ctx))); + snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun, KK_BORROWED, ctx))); kk_box_drop(b, ctx); return kk_string_alloc_dup_valid_utf8(buf, ctx); } diff --git a/kklib/src/thread.c b/kklib/src/thread.c index 716c31455..09956e0e0 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -400,7 +400,7 @@ static kk_promise_t kk_promise_alloc(kk_context_t* ctx) { static void kk_promise_set( kk_promise_t pr, kk_box_t r, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,ctx); + promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr, KK_BORROWED, ctx); kk_box_mark_shared(r,ctx); pthread_mutex_lock(&p->lock); kk_box_drop(p->result,ctx); @@ -422,7 +422,7 @@ static bool kk_promise_available( kk_promise_t pr, kk_context_t* ctx ) { */ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,ctx); + promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,KK_BORROWED,ctx); pthread_mutex_lock(&p->lock); while (kk_box_is_any(p->result)) { // if part of a task group, run other tasks while waiting @@ -521,7 +521,7 @@ kk_lvar_t kk_lvar_alloc(kk_box_t init, kk_context_t* ctx) { void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,ctx); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,KK_BORROWED,ctx); pthread_mutex_lock(&lv->lock); lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx),ctx); kk_box_mark_shared(lv->result,ctx); // todo: can we mark outside the mutex? @@ -532,7 +532,7 @@ void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_box_t kk_lvar_get( kk_lvar_t lvar, kk_box_t bot, kk_function_t is_gte, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,ctx); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,KK_BORROWED,ctx); kk_box_t result; pthread_mutex_lock(&lv->lock); while (true) { diff --git a/kklib/test/main.c b/kklib/test/main.c index 902ae2b48..09a60ee9d 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -427,7 +427,7 @@ static void test_popcount(void) { static void test_box_double(double dx, kk_context_t* ctx) { kk_box_t bx = kk_double_box(dx, ctx); - double e = kk_double_unbox(bx, ctx); + double e = kk_double_unbox(bx, KK_BORROWED, ctx); printf("value: %.20e, box-unbox to: %.20e, box: 0x%016zx\n", dx, e, (intptr_t)bx.box); assert(e == dx || (isnan(e) && isnan(dx))); } @@ -611,7 +611,7 @@ static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { int64_t nsecs = (d.attoseconds / KK_I64(1000000000)); if ((int32_t)nsecs == nsecs) { double frac = ((double)nsecs * 1e-9); - double secs; + double secs = 0; if ((int32_t)secs == d.seconds) { secs = (double)d.seconds; } diff --git a/lib/std/core/core-inline.c b/lib/std/core/core-inline.c index 0733ba061..93765baa6 100644 --- a/lib/std/core/core-inline.c +++ b/lib/std/core/core-inline.c @@ -104,7 +104,7 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { kk_std_core__list xs = cs; while (kk_std_core__is_Cons(xs,ctx)) { struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); - len += kk_utf8_len(kk_char_unbox(cons->head,ctx)); + len += kk_utf8_len(kk_char_unbox(cons->head,KK_BORROWED,ctx)); xs = cons->tail; } // allocate and copy the characters @@ -114,7 +114,7 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { while (kk_std_core__is_Cons(xs,ctx)) { struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); kk_ssize_t count; - kk_utf8_write( kk_char_unbox(cons->head,ctx), p, &count ); + kk_utf8_write( kk_char_unbox(cons->head,KK_BORROWED,ctx), p, &count ); p += count; xs = cons->tail; } diff --git a/lib/std/core/hnd-inline.c b/lib/std/core/hnd-inline.c index b1b510406..ca65fc0d2 100644 --- a/lib/std/core/hnd-inline.c +++ b/lib/std/core/hnd-inline.c @@ -206,7 +206,7 @@ kk_evv_t kk_evv_create(kk_evv_t evv1, kk_vector_t indices, kk_context_t* ctx) { kk_std_core_hnd__ev single; kk_std_core_hnd__ev* buf1 = kk_evv_as_vec(evv1,&len1,&single,ctx); for(kk_ssize_t i = 0; i < len; i++) { - kk_ssize_t idx = kk_ssize_unbox(elems[i],ctx); + kk_ssize_t idx = kk_ssize_unbox(elems[i],KK_BORROWED,ctx); kk_assert_internal(idx < len1); buf2[i] = kk_std_core_hnd__ev_dup( buf1[idx], ctx ); } @@ -223,7 +223,7 @@ kk_evv_t kk_evv_swap_create( kk_vector_t indices, kk_context_t* ctx ) { return kk_evv_swap_create0(ctx); } if (len==1) { - kk_ssize_t i = kk_ssize_unbox(vec[0],ctx); + kk_ssize_t i = kk_ssize_unbox(vec[0],KK_BORROWED,ctx); kk_vector_drop(indices,ctx); return kk_evv_swap_create1(i,ctx); } diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index be59725fb..0cd27fa06 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -18,6 +18,8 @@ module std/core/types pub infixr 30 (&&) pub infixr 20 (||) +// build: 102 + // ---------------------------------------------------------------------------- // Core types // ---------------------------------------------------------------------------- diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index c1a63e060..0a267fbf6 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -136,7 +136,7 @@ static kk_std_core__list kk_regex_exec( kk_box_t bre, kk_string_t str, kk_ssize_ // unpack pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,ctx); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,KK_BORROWED,ctx); kk_ssize_t len = 0; const uint8_t* cstr = NULL; if (re == NULL) goto done; @@ -162,7 +162,7 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (atmost < 0) atmost = KK_SSIZE_MAX; pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,ctx); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,KK_BORROWED,ctx); if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; diff --git a/lib/std/text/regex.kk b/lib/std/text/regex.kk index 99e4afa5e..88fdd53e7 100644 --- a/lib/std/text/regex.kk +++ b/lib/std/text/regex.kk @@ -7,7 +7,7 @@ ---------------------------------------------------------------------------*/ /* Regular expressions. - + The regular expressions conform to the regular expressions of JavaScript as described at */ diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 8f6fa49d5..648af1c97 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -735,18 +735,34 @@ genBoxUnbox name info dataRepr genBox tname info dataRepr genUnbox tname info dataRepr - -genBoxCall prim asBorrowed tp arg - = case cType tp of - CFun _ _ -> primName_t prim "function_t" <.> tupled [arg,ctx] +genBoxCall tp arg + = let prim = "box" + ctx = contextDoc + in case cType tp of + CFun _ _ -> primName_t prim "function_t" <.> tupled ([arg,ctx]) CPrim val | val == "kk_unit_t" || val == "bool" || val == "kk_string_t" -- || val == "kk_integer_t" -> primName_t prim val <.> parens arg -- no context - --CPrim val | val == "int32_t" || val == "double" || val == "unit_t" - -- -> text val <.> arguments [arg] CData name -> primName prim (ppName name) <.> tupled [arg,ctx] _ -> primName_t prim (show (ppType tp)) <.> tupled [arg,ctx] -- kk_box_t, int32_t - where - ctx = if asBorrowed then text "NULL" else contextDoc + + +genUnboxCallOwned tp arg + = genUnboxCall tp arg (text "KK_OWNED") + +genUnboxCallBorrowed tp arg + = genUnboxCall tp arg (text "KK_BORROWED") + +genUnboxCall tp arg argBorrow + = let prim = "unbox" + ctx = contextDoc + in case cType tp of + CFun _ _ -> primName_t prim "function_t" <.> tupled [arg,ctx] -- no borrow + CPrim val | val == "kk_unit_t" || val == "bool" || val == "kk_string_t" + -> primName_t prim val <.> parens arg -- no borrow, no context + | otherwise + -> primName_t prim val <.> tupled ([arg] ++ (if (cPrimCanBeBoxed val) then [argBorrow] else []) ++ [ctx]) + CData name -> primName prim (ppName name) <.> tupled [arg,argBorrow,ctx] + CBox -> primName_t prim (show (ppType tp)) <.> tupled [arg,ctx] primName_t prim s = primName prim $ text $ @@ -768,14 +784,14 @@ genBox name info dataRepr DataEnum -> text "return" <+> text "kk_enum_box" <.> tupled [text "_x"] <.> semi DataIso -> let conInfo = head (dataInfoConstrs info) (isoName,isoTp) = (head (conInfoParams conInfo)) - in text "return" <+> genBoxCall "box" False isoTp (text "_x." <.> ppName (unqualify isoName)) <.> semi - DataStructAsMaybe + in text "return" <+> genBoxCall isoTp (text "_x." <.> ppName (unqualify isoName)) <.> semi + DataStructAsMaybe -> let (conNothing,conJust) = dataStructAsMaybeSplit (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) in text "if" <+> parens (conTestName conNothing <.> arguments [text "_x"]) <+> (text "{ return kk_box_Nothing(); }") <-> text " else" <+> ( - let boxField = genBoxCall "box" False conJustFieldTp + let boxField = genBoxCall conJustFieldTp (text "_x._cons." <.> ppDefName (conInfoName conJust) <.> text "." <.> ppName (unqualify conJustFieldName)) in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) @@ -796,12 +812,12 @@ genBox name info dataRepr genUnbox name info dataRepr = emitToH $ - text "static inline" <+> ppName name <+> ppName name <.> text "_unbox" <.> parameters [text "kk_box_t _x"] <+> block ( + text "static inline" <+> ppName name <+> ppName name <.> text "_unbox" <.> parameters [text "kk_box_t _x", text "kk_borrow_t _borrow"] <+> block ( (case dataRepr of DataEnum -> text "return" <+> parens (ppName name) <.> text "kk_enum_unbox" <.> tupled [text "_x"] DataIso -> let conInfo = head (dataInfoConstrs info) isoTp = snd (head (conInfoParams conInfo)) - in text "return" <+> conCreateNameInfo conInfo <.> arguments [genBoxCall "unbox" False isoTp (text "_x")] + in text "return" <+> conCreateNameInfo conInfo <.> arguments [genUnboxCall isoTp (text "_x") (text "_borrow")] DataStructAsMaybe -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) @@ -810,12 +826,12 @@ genUnbox name info dataRepr <-> text " else" <+> ( text "{ return" <+> conCreateName (conInfoName conJust) <.> arguments [ - genBoxCall "unbox" False conJustFieldTp (text "kk_unbox_Just" <.> arguments [text "_x"]) + genUnboxCall conJustFieldTp (text "kk_unbox_Just" <.> arguments [text "_x", text "_borrow"]) (text "_borrow") ] <.> semi <+> text "}" ) _ | dataReprIsValue dataRepr -> vcat [ ppName name <+> text "_unbox;" - , text "kk_valuetype_unbox" <.> arguments [ppName name, text "_unbox", text "_x"] <.> semi + , text "kk_valuetype_unbox" <.> arguments [ppName name, text "_unbox", text "_x", text "_borrow"] <.> semi , text "return _unbox" ] -- text "unbox_valuetype" <.> arguments [ppName name, text "x"] _ -> text "return" @@ -1277,6 +1293,10 @@ cTypeCon c else CData (typeClassName name) +cPrimCanBeBoxed :: String -> Bool +cPrimCanBeBoxed prim + = prim `elem` ["kk_char_t", "int64_t", "int16_t", "int32_t", "float", "double", "intptr_t", "kk_ssize_t"] + --------------------------------------------------------------------------------- -- Statements @@ -1532,11 +1552,11 @@ genPatternTest doTest eagerPatBind (exprDoc,pattern) return [([],[after],next)] -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon - -> do local <- newVarName "unbox" - let assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] - unbox = genBoxCall "unbox" False targ (ppDefName local) - -- assign = [] - -- unbox = genBoxCall "unbox" True {- borrowing -} targ exprDoc + -> do -- local <- newVarName "unbox" + let -- assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] + -- unbox = genUnboxCallBorrowed targ (ppDefName local) + assign = [] + unbox = genUnboxCallBorrowed targ exprDoc next = genNextPatterns (\self fld -> self) unbox targ [pattern] return [([],assign,[],next)] PatVar tname pattern @@ -2018,7 +2038,7 @@ genExprExternal tname formats [argDoc] | getName tname == nameBox || getName tna tp = case typeOf tname of TFun [(_,fromTp)] _ toTp -> if (isBox) then fromTp else toTp _ -> failure $ ("Backend.C.genExprExternal.unbox: expecting function type: " ++ show tname ++ ": " ++ show (pretty (typeOf tname))) - call = genBoxCall (if (isBox) then "box" else "unbox") False tp argDoc + call = if (isBox) then genBoxCall tp argDoc else genUnboxCallOwned tp argDoc in return ([], call) From 38d22075b211c35109edd00fd2949287a2a2908d Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 16 Feb 2023 14:55:40 -0800 Subject: [PATCH 132/233] fix bitshift in intf boxing --- kklib/include/kklib.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 7e486bd96..b436f1811 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -953,10 +953,10 @@ static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { // Integer value encoding/decoding. May use smaller integers (`kk_intf_t`) // then boxed integers if `kk_intb_t` is larger than the natural register size. -#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - KK_TAG_BITS + (extra)) +#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - (KK_TAG_BITS + (extra))) #define KK_INTF_BOX_MAX(extra) (KK_INTF_MAX >> (KK_TAG_BITS + (extra))) #define KK_INTF_BOX_MIN(extra) (-KK_INTF_BOX_MAX(extra) - 1) -#define KK_UINTF_BOX_MAX(extra) (KK_UINTF_MAX >> (KK_TAG_BITS + (extra))) +#define KK_UINTF_BOX_MAX(extra) (KK_UINTF_MAX >>(KK_TAG_BITS + (extra))) static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { kk_assert_internal(extra_shift >= 0); @@ -968,7 +968,7 @@ static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { static inline kk_intf_t kk_intf_decode(kk_intb_t b, int extra_shift) { kk_assert_internal(extra_shift >= 0); kk_assert_internal(kk_is_value(b) || b == kk_get_context()->kk_box_any.dbox); - kk_intb_t i = kk_sarb( b & ~KK_TAG_VALUE, KK_TAG_BITS + extra_shift); + kk_intb_t i = kk_sarb( b, KK_TAG_BITS + extra_shift); kk_assert_internal(i >= KK_INTF_MIN && i <= KK_INTF_MAX); return (kk_intf_t)i; } From 2ed6c717d3ae6430a008abc7d789f23ce3574b01 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 16 Feb 2023 18:27:04 -0800 Subject: [PATCH 133/233] add addr_t comments --- kklib/include/kklib/platform.h | 36 +++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 28f24ed30..f9b01e86e 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -58,22 +58,24 @@ - `intptr_t` for addresses (where `sizeof(intptr_t) == sizeof(void*)`), - `size_t` for object sizes, - `kk_intx_t` for the natural largest register size (for general arithmetic), + - `kk_addr_t` for raw virtual adresses; usually equal to `intptr_t` but + on capability systems like CHERI, this can be smaller. We always have: - - `|intptr_t| >= |size_t| >= |int|`. + - `|intptr_t| >= |kk_addr_t| >= |size_t| >= |int|`. - `|kk_intx_t| >= |int|`. - system intptr_t size_t int long intx notes - ------------------ ----------- -------- ----- ------ ------ ----------- - x86, arm32 32 32 32 32 32 - x64, arm64, etc. 64 64 32 64 64 - x64 windows 64 64 32 32 64 size_t > long - x32 linux 32 32 32 32 64 intx_t > size_t,intptr_t - arm CHERI 128 64 32 64 64 intptr_t > size_t - riscV 128-bit 128 128 32 64 128 - x86 16-bit small 16 16 16 32 16 long > size_t - x86 16-bit large 32 16 16 32 16 intptr_t/long > size_t - x86 16-bit huge 32 32 16 32 16 size_t > intx_t + system intptr_t kk_addr_t size_t int long intx notes + ------------------ ----------- --------- -------- ----- ------ ------ ----------- + x86, arm32 32 32 32 32 32 32 + x64, arm64, etc. 64 64 64 32 64 64 + x64 windows 64 64 64 32 32 64 size_t > long + x32 linux 32 32 32 32 32 64 intx_t > size_t,intptr_t + arm CHERI 128 64 64 32 64 64 intptr_t > size_t + riscV 128-bit 128 128 128 32 64 128 + x86 16-bit small 16 16 16 16 32 16 long > size_t + x86 16-bit large 32 32 16 16 32 16 intptr_t/long > size_t + x86 16-bit huge 32 32 32 16 32 16 size_t > intx_t We use a signed `size_t` as `kk_ssize_t` (see earlier comments) @@ -87,17 +89,19 @@ system intptr_t size_t intx intb intf notes ----------------------------- --------- -------- ------ ------ ------ ----------- x64, arm64, 64 64 64 64 64 - x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 2^32 (*4) - + x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 16 GiB == 4*2^32 (*) + arm CHERI 128 64 64 128 64 |intb| > |intf| arm CHERI compressed 64-bit 128 64 64 64 64 store addresses only in a box arm CHERI compressed 32-bit 128 64 64 32 32 compress address as well riscV 128-bit 128 128 128 128 128 - riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 (*4) - riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 2^32 (*4) + riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 + riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 16 GiB == 4*2^32 (*) x32 linux 32 32 64 32 32 |intx| > |intb| + + (*) times 4 as we have 2 spare bits after assuming aligned addresses. --------------------------------------------------------------------------------------*/ From 2c013c4e692d302eed005b1a75c47a266a003814 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 16 Feb 2023 18:37:52 -0800 Subject: [PATCH 134/233] make cptr unbox always borrowed --- kklib/include/kklib.h | 2 +- kklib/include/kklib/box.h | 4 ++-- kklib/src/box.c | 9 +++++---- kklib/src/string.c | 2 +- kklib/src/thread.c | 8 ++++---- lib/std/text/regex-inline.c | 4 ++-- 6 files changed, 15 insertions(+), 14 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index b436f1811..58f8a8667 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 102 // modify on changes to trigger recompilation +#define KKLIB_BUILD 103 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index f880faea5..58e5dedbb 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -396,9 +396,9 @@ typedef struct kk_cptr_raw_s { } *kk_cptr_raw_t; kk_decl_export kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); +kk_decl_export void* kk_cptr_raw_unbox_borrowed(kk_box_t b, kk_context_t* ctx); kk_decl_export kk_box_t kk_cptr_box(void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); +kk_decl_export void* kk_cptr_unbox_borrowed(kk_box_t b, kk_context_t* ctx); // C function pointers typedef void (*kk_cfun_ptr_t)(void); diff --git a/kklib/src/box.c b/kklib/src/box.c index da9765d26..8d8428e47 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -201,10 +201,11 @@ kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx) { return kk_ptr_box(&raw->_block,ctx); } -void* kk_cptr_raw_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { +// always assumed borrowed! If dropped here a C free routine may make the returned pointer invalid. +void* kk_cptr_raw_unbox_borrowed(kk_box_t b, kk_context_t* ctx) { kk_cptr_raw_t raw = kk_block_unbox_as(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); void* p = raw->cptr; - if (kk_is_owned(borrow)) { kk_base_type_drop(raw, ctx); } + // if (kk_is_owned(borrow)) { kk_base_type_drop(raw, ctx); } return p; } @@ -220,12 +221,12 @@ kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { } } -void* kk_cptr_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { +void* kk_cptr_unbox_borrowed(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_value(b)) { return (void*)((intptr_t)kk_intf_unbox(b)); } else { - return kk_cptr_raw_unbox(b,borrow,ctx); + return kk_cptr_raw_unbox_borrowed(b,ctx); } } diff --git a/kklib/src/string.c b/kklib/src/string.c index e0ca416ae..6ea74efa4 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -959,7 +959,7 @@ kk_string_t kk_show_any(kk_box_t b, kk_context_t* ctx) { } else if (tag == KK_TAG_FUNCTION) { struct kk_function_s* fun = kk_block_assert(struct kk_function_s*, p, KK_TAG_FUNCTION); - snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun, KK_BORROWED, ctx))); + snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox_borrowed(fun->fun,ctx))); kk_box_drop(b, ctx); return kk_string_alloc_dup_valid_utf8(buf, ctx); } diff --git a/kklib/src/thread.c b/kklib/src/thread.c index 09956e0e0..dd9ae420f 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -400,7 +400,7 @@ static kk_promise_t kk_promise_alloc(kk_context_t* ctx) { static void kk_promise_set( kk_promise_t pr, kk_box_t r, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr, KK_BORROWED, ctx); + promise_t* p = (promise_t*)kk_cptr_raw_unbox_borrowed(pr, ctx); kk_box_mark_shared(r,ctx); pthread_mutex_lock(&p->lock); kk_box_drop(p->result,ctx); @@ -422,7 +422,7 @@ static bool kk_promise_available( kk_promise_t pr, kk_context_t* ctx ) { */ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr,KK_BORROWED,ctx); + promise_t* p = (promise_t*)kk_cptr_raw_unbox_borrowed(pr,ctx); pthread_mutex_lock(&p->lock); while (kk_box_is_any(p->result)) { // if part of a task group, run other tasks while waiting @@ -521,7 +521,7 @@ kk_lvar_t kk_lvar_alloc(kk_box_t init, kk_context_t* ctx) { void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,KK_BORROWED,ctx); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox_borrowed(lvar,ctx); pthread_mutex_lock(&lv->lock); lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx),ctx); kk_box_mark_shared(lv->result,ctx); // todo: can we mark outside the mutex? @@ -532,7 +532,7 @@ void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_box_t kk_lvar_get( kk_lvar_t lvar, kk_box_t bot, kk_function_t is_gte, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar,KK_BORROWED,ctx); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox_borrowed(lvar,ctx); kk_box_t result; pthread_mutex_lock(&lv->lock); while (true) { diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index 0a267fbf6..185e6cdde 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -136,7 +136,7 @@ static kk_std_core__list kk_regex_exec( kk_box_t bre, kk_string_t str, kk_ssize_ // unpack pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,KK_BORROWED,ctx); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox_borrowed(bre,ctx); kk_ssize_t len = 0; const uint8_t* cstr = NULL; if (re == NULL) goto done; @@ -162,7 +162,7 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (atmost < 0) atmost = KK_SSIZE_MAX; pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre,KK_BORROWED,ctx); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox_borrowed(bre,ctx); if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; From 84fbd7fe61d7bd5d9250ff5c85551cccbced9b6e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Sun, 19 Feb 2023 17:42:45 -0800 Subject: [PATCH 135/233] WIP: better size calculation --- src/Backend/C/Box.hs | 3 +- src/Backend/C/FromCore.hs | 8 +- src/Backend/C/Parc.hs | 22 ++--- src/Backend/C/ParcReuse.hs | 2 +- src/Common/Syntax.hs | 10 ++- src/Core/Core.hs | 3 +- src/Core/Parse.hs | 22 +++-- src/Kind/Infer.hs | 165 ++++++++++++++++++++++++++++++------- src/Syntax/Parse.hs | 4 +- src/Type/Pretty.hs | 8 +- src/Type/Type.hs | 5 +- 11 files changed, 189 insertions(+), 63 deletions(-) diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index d35a32e5f..7f777ef08 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -395,7 +395,8 @@ boxConRepr = ConSingle nameTpBox (DataSingle False) 0 boxConInfo :: ConInfo boxConInfo = ConInfo nameBox nameTpBox [a] [] [(nameNil,TVar a)] tp - Inductive rangeNull [] [Public] True Public "" + Inductive rangeNull [] [Public] True + [(nameNil,TVar a)] 0 {- size is wrong with knowing the platform ? -} 1 1 Public "" where tp = TForall [a] [] (TFun [(nameNil,TVar a)] typeTotal typeBoxStar) a = TypeVar (0) kindStar Bound diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 648af1c97..1e04bd52c 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -444,9 +444,9 @@ genTypeDefPre (Data info isExtend) -- generate the type declaration if (dataRepr == DataEnum) then let enumIntTp = case (dataInfoDef info) of - DataDefValue 1 0 -> "uint8_t" - DataDefValue 2 0 -> "uint16_t" - _ -> "uint32_t" + DataDefValue 1 0 _ -> "uint8_t" + DataDefValue 2 0 _ -> "uint16_t" + _ -> "uint32_t" ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> @@ -796,7 +796,7 @@ genBox name info dataRepr in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) _ -> case dataInfoDef info of - DataDefValue raw scancount + DataDefValue raw scancount alignment -> let extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors docScanCount = {- if (hasTagField dataRepr) then ppName name <.> text "_scan_count" <.> arguments [text "_x"] diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index fefdb3d38..8e53ced7d 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -589,7 +589,7 @@ getBoxForm' :: Platform -> Newtypes -> Type -> BoxForm getBoxForm' platform newtypes tp = -- trace ("getBoxForm' of " ++ show (pretty tp)) $ case getDataDef' newtypes tp of - Just (DataDefValue m 0) -- 0 scan fields, m is size in bytes of raw fields + Just (DataDefValue m 0 _) -- 0 scan fields, m is size in bytes of raw fields -> -- trace " 0 scan fields" $ case extractDataDefType tp of Just name @@ -600,7 +600,7 @@ getBoxForm' platform newtypes tp _ -> if m < sizePtr platform -- for example, `bool`, but not `int64` then BoxIdentity else BoxRaw - Just (DataDefValue _ _) + Just (DataDefValue{}) -> BoxValue Just _ -> BoxIdentity @@ -634,15 +634,15 @@ needsDupDrop :: Type -> Parc Bool needsDupDrop tp = do dd <- getDataDef tp return $ case dd of - (DataDefValue _ 0) -> False - _ -> True + (DataDefValue _ 0 _) -> False + _ -> True isValueType :: Type -> Parc Bool isValueType tp = do dd <- getDataDef tp return $ case dd of - (DataDefValue _ _) -> True - _ -> False + (DataDefValue{}) -> True + _ -> False data ValueForm = ValueAllRaw -- just bits @@ -652,10 +652,10 @@ data ValueForm getValueForm' :: Newtypes -> Type -> Maybe ValueForm getValueForm' newtypes tp = case getDataDef' newtypes tp of - Just (DataDefValue _ 0) -> Just ValueAllRaw - Just (DataDefValue 0 1) -> Just ValueOneScan - Just (DataDefValue _ _) -> Just ValueOther - _ -> Nothing + Just (DataDefValue _ 0 _) -> Just ValueAllRaw + Just (DataDefValue 0 1 _) -> Just ValueOneScan + Just (DataDefValue _ _ _) -> Just ValueOther + _ -> Nothing getValueForm :: Type -> Parc (Maybe ValueForm) getValueForm tp = (`getValueForm'` tp) <$> getNewtypes @@ -694,7 +694,7 @@ genDupDrop isDup tname mbConRepr mbScanCount -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) - (DataDefValue _ 0, _, _) + (DataDefValue _ 0 _, _, _) -> do -- parcTrace $ (" value with no scan fields: " ++ show di ++ ", " ++ show tname) return Nothing -- value with no scan fields _ -> do -- parcTrace $ " dup/drop(1), " ++ show tname diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index cd7fbd180..961212fc8 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -649,7 +649,7 @@ orderConFieldsEx platform newtypes isOpen fields visit (rraw,rmixed,rscan,scanCount) (field@(name,tp) : fs) = let mDataDefRepr = newtypesDataDefRepr newtypes tp in case mDataDefRepr of - Just (DataDefValue raw scan, dataRepr) + Just (DataDefValue raw scan alignment, dataRepr) -> let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index f4c5af00d..d42a5cc41 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -157,6 +157,7 @@ readOperationSort s "fun" -> Just OpFun "brk" -> Just OpExcept "ctl" -> Just OpControl + -- legacy "rawctl" -> Just OpControlRaw "except" -> Just OpExcept "control" -> Just OpControl @@ -174,7 +175,10 @@ instance Show DataKind where show CoInductive = "cotype" show Retractive = "rectype" -data DataDef = DataDefValue{ rawFields :: Int {- size in bytes -}, scanFields :: Int {- count of scannable fields -}} +data DataDef = DataDefValue{ rawSize :: Int {- size in bytes -}, + scanFields :: Int {- count of scannable fields -}, + alignment :: Int {- minimal alignment -} + } | DataDefNormal | DataDefAuto -- Value or Normal; determined by kind inference | DataDefRec @@ -183,7 +187,7 @@ data DataDef = DataDefValue{ rawFields :: Int {- size in bytes -}, scanFields :: instance Show DataDef where show dd = case dd of - DataDefValue m n -> "val(raw:" ++ show m ++ ",scan:" ++ show n ++ ")" + DataDefValue m n a -> "val(rawSize=" ++ show m ++ ",scanCount=" ++ show n ++ ",alignment=" ++ show a ++ ")" DataDefNormal{} -> "normal" DataDefRec -> "rec" DataDefOpen -> "open" @@ -203,7 +207,7 @@ dataDefIsOpen ddef dataDefIsValue ddef = case ddef of - DataDefValue _ _ -> True + DataDefValue{} -> True _ -> False {-------------------------------------------------------------------------- diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 324a0c6a0..deea5e23f 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -150,7 +150,8 @@ exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum 0) patExprBool name tag = let tname = TName name typeBool conEnum = ConEnum nameTpBool DataEnum tag - conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False Public "" + conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False + [] 1 0 1 Public "" pat = PatCon tname [] conEnum [] [] typeBool conInfo False expr = Con tname conEnum in (pat,expr) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 7d0f9ff38..13a2f74d5 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -264,9 +264,12 @@ conDecl tname foralls sort env -- trace ("core con: " ++ show name) $ return () (env1,existss) <- typeParams env (env2,params) <- parameters env1 + (size,scanCount,align) <- parseSizes tp <- typeAnnot env2 let params2 = [(if nameIsNil name then newFieldName i else name, tp) | ((name,tp),i) <- zip params [1..]] - let con = (ConInfo (qualify (modName env) name) tname foralls existss params2 tp sort rangeNull (map (const rangeNull) params2) (map (const Public) params2) False vis doc) + orderedFields = params2 -- no need to order? + let con = (ConInfo (qualify (modName env) name) tname foralls existss params2 tp sort rangeNull (map (const rangeNull) params2) (map (const Public) params2) False + orderedFields size scanCount align vis doc) -- trace (show con ++ ": " ++ show params2) $ return con @@ -286,16 +289,23 @@ parseTypeMod = do{ specialId "open"; return (DataDefOpen, False, Inductive) } <|> do{ specialId "extend"; return (DataDefOpen, True, Inductive) } <|> do specialId "value" - (m,n) <- braced $ do (m,_) <- integer - comma - (n,_) <- integer - return (m,n) - return (DataDefValue (fromInteger m) (fromInteger n), False, Inductive) + (m,n,a) <- parseSizes + return (DataDefValue m n a, False, Inductive) <|> do{ specialId "co"; return (DataDefNormal, False, CoInductive) } <|> do{ specialId "rec"; return (DataDefNormal, False, Retractive) } <|> return (DataDefNormal, False, Inductive) "" +parseSizes :: LexParser (Int,Int,Int) +parseSizes + = braced $ do (m,_) <- integer + comma + (n,_) <- integer + comma + (a,_) <- integer + return (fromInteger m, fromInteger n, fromInteger a) + + {-------------------------------------------------------------------------- Value definitions --------------------------------------------------------------------------} diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 3f405d0fd..c7bbdd679 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -28,12 +28,13 @@ import Lib.Trace import Data.Char(isAlphaNum) import Data.List(groupBy,intersperse,nubBy,sortOn) import Data.Maybe(catMaybes) +import Control.Monad(when) import Lib.PPrint import Common.Failure import Common.Unique( uniqueId, setUnique, unique ) import Common.Error -import Common.ColorScheme( ColorScheme, colorType, colorSource ) +import Common.ColorScheme( ColorScheme, colorType, colorSource, colorCons ) import Common.Range import Common.Syntax( Platform(..) ) import Common.Name @@ -805,13 +806,18 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then mapM (\karg -> do{ id <- uniqueId "k"; return (TypeVar id karg Bound) }) kargs -- invent parameters if they are not given (and it has an arrow kind) else mapM (\param -> freshTypeVar param Bound) params' let tvarMap = M.fromList (zip (map getName params') typeVars) - consinfos <- mapM (resolveConstructor (getName newtp') sort (not (dataDefIsOpen ddef) && length constructors == 1) typeResult typeVars tvarMap) constructors - let (constructors',infos) = unzip consinfos + cs <- getColorScheme let qname = getName newtp' fname = unqualify qname name = if (isHandlerName fname) then fromHandlerName fname else fname nameDoc = color (colorType cs) (pretty name) + + consinfos <- mapM (resolveConstructor (getName newtp') sort + (dataDefIsOpen ddef) (not (dataDefIsOpen ddef) && length constructors == 1) + typeResult typeVars tvarMap) constructors + let (constructors',infos) = unzip consinfos + --check recursion if (sort == Retractive) then return () @@ -833,7 +839,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort ddef' <- case ddef of DataDefNormal -> return (if (isRec) then DataDefRec else DataDefNormal) - DataDefValue _ _ | isRec + DataDefValue{} | isRec -> do addError range (text "Type" <+> nameDoc <+> text "cannot be declared as a value type since it is recursive.") return ddef DataDefAuto | isRec @@ -849,20 +855,20 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort do platform <- getPlatform dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc infos case (ddef,dd) of -- note: m = raw, n = scan - (DataDefValue _ _, DataDefValue m n) + (DataDefValue _ _ _, DataDefValue m n a) -> if (hasKindStarResult (getKind typeResult)) - then return (DataDefValue m n) + then return (DataDefValue m n a) else do addError range (text "Type" <+> nameDoc <+> text "is declared as a value type but does not have a value kind ('V').") -- should never happen? return DataDefNormal - (DataDefValue _ _, DataDefNormal) + (DataDefValue _ _ _, DataDefNormal) -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? return DataDefNormal - (DataDefAuto, DataDefValue m n) - -> if ((m + (n*sizePtr platform)) <= 3*(sizePtr platform) + (DataDefAuto, DataDefValue m n a) + -> if ((m + (n*sizeField platform)) <= 3*(sizeField platform) && hasKindStarResult (getKind typeResult) && (sort /= Retractive)) then -- trace ("default to value: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefValue m n) + return (DataDefValue m n a) else -- trace ("default to reference: " ++ show name ++ ": " ++ show (m,n)) $ return (DataDefNormal) _ -> return DataDefNormal @@ -879,11 +885,11 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort = do ddefs <- mapM (toDefValue nameDoc) conInfos ddef <- maxDataDefs platform qname isVal nameDoc ddefs case ddef of - DataDefValue 0 0 -- enumeration + DataDefValue 0 0 0 -- enumeration -> let n = length conInfos - in if (n < 256) then return $ DataDefValue 1 0 -- uint8_t - else if (n < 65536) then return $ DataDefValue 2 0 -- uint16_t - else return $ DataDefValue 4 0 -- uint32_t + in if (n < 256) then return $ DataDefValue 1 0 1 -- uint8_t + else if (n < 65536) then return $ DataDefValue 2 0 2 -- uint16_t + else return $ DataDefValue 4 0 4 -- uint32_t _ -> return ddef toDefValue :: Doc -> ConInfo -> KInfer (Int,Int) @@ -895,7 +901,8 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort -- note: (m = raw, n = scan) maxDataDefs :: Platform -> Name -> Bool -> Doc -> [(Int,Int)] -> KInfer DataDef - maxDataDefs platform name False nameDoc [] = return DataDefNormal + maxDataDefs platform name False nameDoc [] -- reference type, no constructors + = return DataDefNormal maxDataDefs platform name True nameDoc [] -- primitive abstract value type with no constructors = do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) then 4 @@ -914,19 +921,20 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then do addWarning range (text "Type:" <+> nameDoc <+> text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform)) return (sizePtr platform) else return size - return (DataDefValue m 0) - maxDataDefs platform name isVal nameDoc [(m,n)] = return (DataDefValue m n) + return (DataDefValue m 0 m) + maxDataDefs platform name isVal nameDoc [(m,n)] -- singleton value + = return (DataDefValue m n m) maxDataDefs platform name isVal nameDoc (dd:dds) = do dd2 <- maxDataDefs platform name isVal nameDoc dds case (dd,dd2) of - ((0,0), DataDefValue m n) -> return (DataDefValue m n) - ((m,n), DataDefValue 0 0) -> return (DataDefValue m n) - ((m1,0), DataDefValue m2 0) -> return (DataDefValue (max m1 m2) 0) - ((0,n1), DataDefValue 0 n2) -> return (DataDefValue 0 (max n1 n2)) - ((m1,n1), DataDefValue m2 n2) + ((0,0), DataDefValue m n a) -> return (DataDefValue m n a) + ((m,n), DataDefValue 0 0 a) -> return (DataDefValue m n a) + ((m1,0), DataDefValue m2 0 a) -> return (DataDefValue (max m1 m2) 0 a) + ((0,n1), DataDefValue 0 n2 a) -> return (DataDefValue 0 (max n1 n2) a) + ((m1,n1), DataDefValue m2 n2 a) -- TODO: mixed raw is ok? -- | m1 == m2 -> return (DataDefValue m1 (max n1 n2)) - | n1 == n2 -> return (DataDefValue (max m1 m2) n1) + | n1 == n2 -> return (DataDefValue (max m1 m2) n1 a) | otherwise -> do if (isVal) then -- addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors which varying raw types and regular types." <-> @@ -945,7 +953,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort walk m n [] = return (m,n) walk m n (dd:dds) = do case dd of - DataDefValue m1 n1 + DataDefValue m1 n1 _ -> do if (m1 > 0 && n1 > 0) -- mixed raw and scan fields? then mapM_ (checkNoClash nameDoc m1 n1) dds else return () @@ -955,7 +963,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort checkNoClash :: Doc -> Int -> Int -> DataDef -> KInfer () checkNoClash nameDoc m1 n1 dd = case dd of - DataDefValue m2 n2 | m2 > 0 && n2 > 0 + DataDefValue m2 n2 _ | m2 > 0 && n2 > 0 -> do addError range (text "Type:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> text ("hint: use 'box' on either field to make it a non-value type.")) _ -> return () @@ -1028,8 +1036,8 @@ resolveKind infkind resolve (KICon kind) = kind resolve (KIApp k1 k2) = KApp (resolve k1) (resolve k2) -resolveConstructor :: Name -> DataKind -> Bool -> Type -> [TypeVar] -> M.NameMap TypeVar -> UserCon (KUserType InfKind) UserType InfKind -> KInfer (UserCon Type Type Kind, ConInfo) -resolveConstructor typeName typeSort isSingleton typeResult typeParams idmap (UserCon name exist params mbResult rngName rng vis doc) +resolveConstructor :: Name -> DataKind -> Bool -> Bool -> Type -> [TypeVar] -> M.NameMap TypeVar -> UserCon (KUserType InfKind) UserType InfKind -> KInfer (UserCon Type Type Kind, ConInfo) +resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams idmap (UserCon name exist params mbResult rngName rng vis doc) = do qname <- qualifyDef name exist' <- mapM resolveTypeBinder exist existVars <- mapM (\ename -> freshTypeVar ename Bound) exist' @@ -1042,16 +1050,113 @@ resolveConstructor typeName typeSort isSingleton typeResult typeParams idmap (Us if (null params') then result' else typeFun [(binderName p, binderType p) | (_,p) <- params'] typeTotal result' addRangeInfo rng (Decl "con" qname (mangleConName qname)) addRangeInfo rngName (Id qname (NICon scheme) True) + let fields = map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params')) + (orderedFields,size,scanCount,alignment) <- orderConFields rng name isOpen fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars - (map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params'))) + fields scheme typeSort rngName (map (binderNameRange . snd) params') (map fst params') isSingleton - vis - doc) + orderedFields size scanCount alignment + vis doc) + + +--------------------------------------------------------- +-- Determine the size of a constructor +--------------------------------------------------------- + +-- order constructor fields of constructors with raw field so the regular fields come first to be scanned. +-- return the ordered fields, the byte size of the allocation, and the scan count (including tags)} +-- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes +orderConFields :: Range -> Name -> Bool -> [(Name,Type)] -> KInfer ([(Name,Type)],Int,Int,Int) +orderConFields range cname isOpen fields + = do visit ([], [], [], if isOpen then 1 else 0, 0) fields + where + visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> KInfer ([(Name,Type)],Int,Int,Int) + visit (rraw, rmixed, rscan, scanCount0, alignment0) [] + = do when (length rmixed > 1) $ + do cs <- getColorScheme + let nameDoc = color (colorCons cs) (pretty cname) + addError range (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + text ("hint: use 'box' on either field to make it a non-value type.")) + platform <- getPlatform + let -- scancount and size before any mixed and raw fields + preSize = scanCount0 * sizeField platform + + -- if there is a mixed value member (with scan fields) we may need to add padding scan fields (!) + -- (or otherwise the C compiler may insert uninitialized padding) + (padding,mixedScan) + = case rmixed of + ((_,_,scan,ralign):_) + -> let headerSize = 8 -- always 64-bit (?) + padSize = (headerSize + preSize) `mod` ralign + padCount = padSize `div` sizeField platform + in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ + ([((newHiddenName ("padding" ++ show i),typeInt),sizeField platform,1,sizeField platform) | i <- [1..padCount]] + ,scan + padCount) + [] -> ([],0) + + -- calculate the rest now + scanCount = scanCount0 + mixedScan + alignment = if scanCount > 0 then max alignment0 (sizeField platform) else alignment0 + rest = padding ++ rmixed ++ reverse rraw + restSizes = [size | (_field,size,_scan,_align) <- rest] + restFields= [field | (field,_size,_scan,_align) <- rest] + size = alignedSum preSize restSizes + return (reverse rscan ++ restFields, size, scanCount, alignment) + + visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) + = do mDataDef <- getDataDef tp + case mDataDef of + Just (DataDefValue raw scan align) + -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors + let alignment = max align alignment0 in + if (raw > 0 && scan > 0) + then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) + -- but we count them to be sure (and for function data) + visit (rraw, (field,raw,scan,align):rmixed, rscan, scanCount, alignment) fs + else if (raw > 0) + then visit (insertRaw field raw scan align rraw, rmixed, rscan, scanCount, alignment) fs + else visit (rraw, rmixed, field:rscan, scanCount + scan, alignment) fs + _ -> visit (rraw, rmixed, field:rscan, scanCount + 1, alignment0) fs + + -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype + insertRaw :: (Name,Type) -> Int -> Int -> Int -> [((Name,Type),Int,Int,Int)] -> [((Name,Type),Int,Int,Int)] + insertRaw field raw scan align ((f,r,s,a):rs) + | align <= a && raw <= r = (field,raw,scan,align):(f,r,s,a):rs + | otherwise = (f,r,s,a):insertRaw field raw scan align rs + insertRaw field raw scan align [] + = [(field,raw,scan,align)] + + + +-- | Return the DataDef for a type. +-- This may be 'Nothing' for abstract types. +getDataDef :: Type -> KInfer (Maybe DataDef) +getDataDef tp + = case extractDataDefType tp of + Nothing -> return $ Just DataDefNormal + Just name | name == nameTpBox -> return $ Just DataDefNormal + Just name -> do mdi <- lookupDataInfo name + case mdi of + Nothing -> return Nothing + Just di -> return $ Just (dataInfoDef di) + where + extractDataDefType :: Type -> Maybe Name + extractDataDefType tp + = case expandSyn tp of + TApp t _ -> extractDataDefType t + TForall _ _ t -> extractDataDefType t + TCon tc -> Just (typeConName tc) + _ -> Nothing + + +--------------------------------------------------------- +-- +--------------------------------------------------------- resolveConParam :: M.NameMap TypeVar -> (Visibility,ValueBinder (KUserType InfKind) (Maybe (Expr UserType))) -> KInfer (Visibility,ValueBinder Type (Maybe (Expr Type))) resolveConParam idmap (vis,vb) diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 5893ddede..049e4ceed 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -563,7 +563,7 @@ structDecl dvis = (try $ do (vis,dvis,rng) <- do{ rng <- keyword "abstract"; return (Public,Private,rng) } <|> do{ (vis,rng) <- visibility dvis; return (vis,vis,rng) } - ddef <- do { specialId "value"; return (DataDefValue 0 0) } + ddef <- do { specialId "value"; return (DataDefValue 0 0 0) } <|> do { specialId "reference"; return DataDefNormal } <|> do { return DataDefAuto } (trng,doc) <- dockeyword "struct" @@ -607,7 +607,7 @@ typeDeclKind try( do (ddef,isExtend) <- do { specialId "open"; return (DataDefOpen, False) } <|> do { specialId "extend"; return (DataDefOpen, True) } - <|> do { specialId "value"; return (DataDefValue 0 0, False) } + <|> do { specialId "value"; return (DataDefValue 0 0 0, False) } <|> do { specialId "reference"; return (DataDefNormal, False) } <|> return (DataDefAuto, False) (rng,doc) <- dockeyword "type" diff --git a/src/Type/Pretty.hs b/src/Type/Pretty.hs index d4558660d..a4ab684bf 100644 --- a/src/Type/Pretty.hs +++ b/src/Type/Pretty.hs @@ -244,7 +244,7 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki else case datadef of DataDefRec -> text "recursive " DataDefOpen -> text "open " - DataDefValue m n -> text ("value{" ++ show m ++ "," ++ show n ++ "} ") + DataDefValue m n a -> text ("value{" ++ show m ++ "," ++ show n ++ "," ++ show a ++ "} ") _ -> empty) <.> (case datakind of Inductive -> keyword env "type" @@ -259,7 +259,8 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki indent 2 (vcat (map (prettyConInfo env publicOnly) cons)) <-> text "}") else empty)) -prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields scheme sort range paramRanges paramVis singleton vis doc) +prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields scheme sort range paramRanges paramVis singleton + orderedFields size scanCount alignment vis doc) = if (publicOnly && isPrivate vis) then empty else (prettyComment env0 doc $ (if publicOnly then empty else ppVis env0 vis) <.> @@ -268,7 +269,8 @@ prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields sche (if null exists then empty else (angled (map (ppTypeVar env) exists))) <.> (if null fields then empty - else parens (commaSep (map (ppField env) (zip paramVis fields)))) + else parens (commaSep (map (ppField env) (zip paramVis fields)))) <.> + (text "{" <.> pretty size <.> comma <.> pretty scanCount <.> comma <.> pretty alignment <.> text "}") <+> text ":" <+> ppType env scheme <.> semi) where ppField env (fvis,(name,tp)) diff --git a/src/Type/Type.hs b/src/Type/Type.hs index fd24e478a..495e05683 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- Copyright 2012-2021, Microsoft Research, Daan Leijen. -- -- This is free software; you can redistribute it and/or modify it under the @@ -202,6 +201,10 @@ data ConInfo = ConInfo{ conInfoName :: Name , conInfoParamRanges :: [Range] , conInfoParamVis :: [Visibility] , conInfoSingleton :: Bool -- ^ is this the only constructor of this type? + , conInfoOrderedParams :: [(Name,Type)] -- ^ fields ordered by size + , conInfoSize :: Int + , conInfoScanFields :: Int + , conInfoAlignment :: Int , conInfoVis :: Visibility , conInfoDoc :: String } From 082620550784a86194aa3159bb851b483198b05e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 20 Feb 2023 12:06:47 -0800 Subject: [PATCH 136/233] WIP: improved size calc; add ValueRepr --- src/Backend/C/Box.hs | 4 +- src/Backend/C/FromCore.hs | 12 ++-- src/Backend/C/Parc.hs | 16 ++--- src/Backend/C/ParcReuse.hs | 26 ++++--- src/Common/Syntax.hs | 78 +++++++++++++++----- src/Core/Core.hs | 9 ++- src/Core/Parse.hs | 24 ++++--- src/Kind/Infer.hs | 142 ++++++++++++++----------------------- src/Syntax/Parse.hs | 4 +- src/Type/Pretty.hs | 6 +- src/Type/Type.hs | 14 ++-- 11 files changed, 185 insertions(+), 150 deletions(-) diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index 7f777ef08..549ff9b21 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -396,7 +396,9 @@ boxConInfo :: ConInfo boxConInfo = ConInfo nameBox nameTpBox [a] [] [(nameNil,TVar a)] tp Inductive rangeNull [] [Public] True - [(nameNil,TVar a)] 0 {- size is wrong with knowing the platform ? -} 1 1 Public "" + [(nameNil,TVar a)] + (ValueRepr 0 1 1 0 {- size is wrong with knowing the platform ? -}) + Public "" where tp = TForall [a] [] (TFun [(nameNil,TVar a)] typeTotal typeBoxStar) a = TypeVar (0) kindStar Bound diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 1e04bd52c..8a486ddc2 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -444,9 +444,9 @@ genTypeDefPre (Data info isExtend) -- generate the type declaration if (dataRepr == DataEnum) then let enumIntTp = case (dataInfoDef info) of - DataDefValue 1 0 _ -> "uint8_t" - DataDefValue 2 0 _ -> "uint16_t" - _ -> "uint32_t" + DataDefValue (ValueRepr 1 0 _ _) -> "uint8_t" + DataDefValue (ValueRepr 2 0 _ _) -> "uint16_t" + _ -> "uint32_t" ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> @@ -796,12 +796,12 @@ genBox name info dataRepr in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) _ -> case dataInfoDef info of - DataDefValue raw scancount alignment - -> let extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors + DataDefValue (ValueRepr raw scancount alignment _) + -> let -- extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors docScanCount = {- if (hasTagField dataRepr) then ppName name <.> text "_scan_count" <.> arguments [text "_x"] else -} - pretty (scancount + extra) <+> text "/* scan count */" + pretty (scancount {- + extra -}) <+> text "/* scan count */" in vcat [ text "kk_box_t _box;" , text "kk_valuetype_box" <.> arguments [ppName name, text "_box", text "_x", docScanCount diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 8e53ced7d..ac9b2d84d 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -589,7 +589,7 @@ getBoxForm' :: Platform -> Newtypes -> Type -> BoxForm getBoxForm' platform newtypes tp = -- trace ("getBoxForm' of " ++ show (pretty tp)) $ case getDataDef' newtypes tp of - Just (DataDefValue m 0 _) -- 0 scan fields, m is size in bytes of raw fields + Just (DataDefValue (ValueRepr m 0 _ _)) -- 0 scan fields, m is size in bytes of raw fields -> -- trace " 0 scan fields" $ case extractDataDefType tp of Just name @@ -634,8 +634,8 @@ needsDupDrop :: Type -> Parc Bool needsDupDrop tp = do dd <- getDataDef tp return $ case dd of - (DataDefValue _ 0 _) -> False - _ -> True + (DataDefValue vr) | valueReprIsRaw vr -> False + _ -> True isValueType :: Type -> Parc Bool isValueType tp @@ -652,10 +652,10 @@ data ValueForm getValueForm' :: Newtypes -> Type -> Maybe ValueForm getValueForm' newtypes tp = case getDataDef' newtypes tp of - Just (DataDefValue _ 0 _) -> Just ValueAllRaw - Just (DataDefValue 0 1 _) -> Just ValueOneScan - Just (DataDefValue _ _ _) -> Just ValueOther - _ -> Nothing + Just (DataDefValue (ValueRepr _ 0 _ _)) -> Just ValueAllRaw + Just (DataDefValue (ValueRepr 0 1 _ _)) -> Just ValueOneScan + Just (DataDefValue _) -> Just ValueOther + _ -> Nothing getValueForm :: Type -> Parc (Maybe ValueForm) getValueForm tp = (`getValueForm'` tp) <$> getNewtypes @@ -694,7 +694,7 @@ genDupDrop isDup tname mbConRepr mbScanCount -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) - (DataDefValue _ 0 _, _, _) + (DataDefValue vr, _, _) | valueReprIsRaw vr -> do -- parcTrace $ (" value with no scan fields: " ++ show di ++ ", " ++ show tname) return Nothing -- value with no scan fields _ -> do -- parcTrace $ " dup/drop(1), " ++ show tname diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 961212fc8..74b1ab926 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -583,20 +583,23 @@ ruTrace msg getRuConSize :: Type -> Reuse (Maybe (Int, Int)) getRuConSize dataType = do newtypes <- getNewtypes - platform <- getPlatform + -- platform <- getPlatform let mdataName = extractDataName dataType if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName then return Nothing else do let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName case mdataInfo of Just dataInfo - -> do let (dataRepr, _) = getDataRepr dataInfo - let cis = dataInfoConstrs dataInfo - let sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis - case sizes of - (s:ss) | all (==s) ss -> pure $ Just s - _ -> pure Nothing - _ -> pure Nothing + -> let ddef = dataInfoDef dataInfo + in case ddef of + DataDefValue vrepr + -> let cis = dataInfoConstrs dataInfo + sizes = map conInfoSize cis + in case sizes of + (s:ss) | all (==s) ss -> return $ Just (valueReprSize vrepr, valScanCount vrepr) + _ -> return Nothing + _ -> return Nothing + _ -> return Nothing where extractDataName :: Type -> Maybe Name extractDataName tp @@ -605,6 +608,11 @@ getRuConSize dataType TCon tc -> Just (typeConName tc) _ -> Nothing +{- +constructorSizeOf :: Platform -> ConInfo -> (Int,Int) +constructorSizeOf platform ci + = (conSize platform ci, conInfoScanFields ci) +-} -- return the allocated size of a constructor. Return 0 for value types or singletons constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) @@ -649,7 +657,7 @@ orderConFieldsEx platform newtypes isOpen fields visit (rraw,rmixed,rscan,scanCount) (field@(name,tp) : fs) = let mDataDefRepr = newtypesDataDefRepr newtypes tp in case mDataDefRepr of - Just (DataDefValue raw scan alignment, dataRepr) + Just (DataDefValue (ValueRepr raw scan alignment _), dataRepr) -> let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index d42a5cc41..8cad5dadf 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2012-2021, Microsoft Research, Daan Leijen. +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. -- -- This is free software; you can redistribute it and/or modify it under the -- terms of the Apache License, Version 2.0. A copy of the License can be @@ -19,7 +19,9 @@ module Common.Syntax( Visibility(..) , Target(..), CTarget(..), JsTarget(..), isTargetC, isTargetJS, isTargetWasm , isPublic, isPrivate , DataDef(..) - , dataDefIsRec, dataDefIsOpen, dataDefIsValue + , dataDefIsRec, dataDefIsOpen, dataDefIsValue, dataDefSize + , ValueRepr(..) + , valueReprIsMixed, valueReprIsRaw, valueReprNew, valueReprZero, valueReprSize , HandlerSort(..) , isHandlerInstance, isHandlerNormal , OperationSort(..), readOperationSort @@ -29,6 +31,8 @@ module Common.Syntax( Visibility(..) , BuildType(..) ) where +import Data.List(intersperse) + {-------------------------------------------------------------------------- Backend targets --------------------------------------------------------------------------} @@ -67,24 +71,26 @@ instance Show Target where data Platform = Platform{ sizePtr :: Int -- sizeof(intptr_t) , sizeSize :: Int -- sizeof(size_t) - , sizeField :: Int -- sizeof(kk_field_t), usually uintptr_t but may be smaller for compression + , sizeField :: Int -- sizeof(kk_field_t), usually intptr_t but may be smaller for compression + , sizeHeader:: Int -- used for correct alignment calculation } platform32, platform64, platform64c, platformJS, platformCS :: Platform -platform32 = Platform 4 4 4 -platform64 = Platform 8 8 8 -platform64c = Platform 8 8 4 -- compressed fields -platformJS = Platform 8 4 8 -platformCS = Platform 8 4 8 +platform32 = Platform 4 4 4 8 +platform64 = Platform 8 8 8 8 +platform64c = Platform 8 8 4 8 -- compressed fields +platformJS = Platform 8 4 8 0 +platformCS = Platform 8 4 8 0 -platformHasCompressedFields (Platform sp _ sf) = (sp /= sf) +platformHasCompressedFields (Platform sp _ sf _) = (sp /= sf) instance Show Platform where - show (Platform sp ss sf) = "Platform(sizeof(void*)=" ++ show sp ++ - ",sizeof(size_t)=" ++ show ss ++ - ",sizeof(kk_box_t)=" ++ show sf ++ - ")" + show (Platform sp ss sf sh) = "Platform(sizeof(void*)=" ++ show sp ++ + ",sizeof(size_t)=" ++ show ss ++ + ",sizeof(kk_box_t)=" ++ show sf ++ + ",sizeof(kk_header_t)=" ++ show sh ++ + ")" alignedSum :: Int -> [Int] -> Int @@ -175,10 +181,7 @@ instance Show DataKind where show CoInductive = "cotype" show Retractive = "rectype" -data DataDef = DataDefValue{ rawSize :: Int {- size in bytes -}, - scanFields :: Int {- count of scannable fields -}, - alignment :: Int {- minimal alignment -} - } +data DataDef = DataDefValue !ValueRepr | DataDefNormal | DataDefAuto -- Value or Normal; determined by kind inference | DataDefRec @@ -187,7 +190,7 @@ data DataDef = DataDefValue{ rawSize :: Int {- size in bytes -}, instance Show DataDef where show dd = case dd of - DataDefValue m n a -> "val(rawSize=" ++ show m ++ ",scanCount=" ++ show n ++ ",alignment=" ++ show a ++ ")" + DataDefValue v -> "val" ++ show v DataDefNormal{} -> "normal" DataDefRec -> "rec" DataDefOpen -> "open" @@ -210,6 +213,45 @@ dataDefIsValue ddef DataDefValue{} -> True _ -> False +dataDefSize :: Platform -> DataDef -> Int +dataDefSize platform ddef + = case ddef of + DataDefValue v -> valSize v + _ -> sizeField platform + + +{-------------------------------------------------------------------------- + Definition kind +--------------------------------------------------------------------------} + +data ValueRepr = ValueRepr{ valRawSize :: !Int {- size in bytes -}, + valScanCount :: !Int {- count of scannable fields -}, + valAlignment :: !Int {- minimal alignment -}, + valSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} + } + deriving Eq + +instance Show ValueRepr where + show (ValueRepr raw scan align full) + = "{" ++ concat (intersperse "," (map show [raw,scan,align,full])) ++ "}" + +valueReprSize :: ValueRepr -> Int +valueReprSize v = valSize v + +valueReprIsMixed :: ValueRepr -> Bool +valueReprIsMixed v = (valRawSize v > 0) && (valScanCount v > 0) + +valueReprIsRaw :: ValueRepr -> Bool +valueReprIsRaw v = (valRawSize v > 0) && (valScanCount v == 0) + +valueReprNew :: Platform -> Int -> Int -> Int -> ValueRepr +valueReprNew platform rawSize scanCount align + = ValueRepr rawSize scanCount align (rawSize + (scanCount * sizeField platform)) + +valueReprZero :: ValueRepr +valueReprZero = ValueRepr 0 0 0 0 + + {-------------------------------------------------------------------------- Definition kind --------------------------------------------------------------------------} diff --git a/src/Core/Core.hs b/src/Core/Core.hs index deea5e23f..8e3ababa4 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -70,6 +70,7 @@ module Core.Core ( -- Data structures , getDataRepr, getDataReprEx, dataInfoIsValue , getConRepr , dataReprIsValue, conReprIsValue + , needsTagField , VarInfo(..), isInfoArity , infoIsRefCounted, infoIsLocal @@ -151,7 +152,7 @@ patExprBool name tag = let tname = TName name typeBool conEnum = ConEnum nameTpBool DataEnum tag conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False - [] 1 0 1 Public "" + [] (ValueRepr 1 0 1 1) Public "" pat = PatCon tname [] conEnum [] [] typeBool conInfo False expr = Con tname conEnum in (pat,expr) @@ -398,6 +399,12 @@ isConAsJust _ = False dataReprIsValue :: DataRepr -> Bool dataReprIsValue drepr = (drepr <= DataStruct) +-- explicit tag field? +needsTagField :: DataRepr -> Bool +needsTagField DataStruct = True +needsTagField DataStructAsMaybe = True +needsTagField rep = False + conReprIsValue :: ConRepr -> Bool conReprIsValue crepr = dataReprIsValue (conDataRepr crepr) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 13a2f74d5..0d4229fbf 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -264,12 +264,12 @@ conDecl tname foralls sort env -- trace ("core con: " ++ show name) $ return () (env1,existss) <- typeParams env (env2,params) <- parameters env1 - (size,scanCount,align) <- parseSizes + vrepr <- parseValueRepr tp <- typeAnnot env2 let params2 = [(if nameIsNil name then newFieldName i else name, tp) | ((name,tp),i) <- zip params [1..]] - orderedFields = params2 -- no need to order? + orderedFields = [] -- no need to reconstruct as it is only used during codegen? let con = (ConInfo (qualify (modName env) name) tname foralls existss params2 tp sort rangeNull (map (const rangeNull) params2) (map (const Public) params2) False - orderedFields size scanCount align vis doc) + orderedFields vrepr vis doc) -- trace (show con ++ ": " ++ show params2) $ return con @@ -289,21 +289,23 @@ parseTypeMod = do{ specialId "open"; return (DataDefOpen, False, Inductive) } <|> do{ specialId "extend"; return (DataDefOpen, True, Inductive) } <|> do specialId "value" - (m,n,a) <- parseSizes - return (DataDefValue m n a, False, Inductive) + vrepr <- parseValueRepr + return (DataDefValue vrepr, False, Inductive) <|> do{ specialId "co"; return (DataDefNormal, False, CoInductive) } <|> do{ specialId "rec"; return (DataDefNormal, False, Retractive) } <|> return (DataDefNormal, False, Inductive) "" -parseSizes :: LexParser (Int,Int,Int) -parseSizes - = braced $ do (m,_) <- integer +parseValueRepr :: LexParser ValueRepr +parseValueRepr + = braced $ do (raw,_) <- integer comma - (n,_) <- integer + (scan,_) <- integer comma - (a,_) <- integer - return (fromInteger m, fromInteger n, fromInteger a) + (align,_) <- integer + comma + (full,_) <- integer + return (ValueRepr (fromInteger raw) (fromInteger scan) (fromInteger align) (fromInteger full)) {-------------------------------------------------------------------------- diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index c7bbdd679..05dd26b29 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -836,7 +836,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort _ -> False -} -- value types - ddef' <- case ddef of + ddef1 <- case ddef of DataDefNormal -> return (if (isRec) then DataDefRec else DataDefNormal) DataDefValue{} | isRec @@ -855,52 +855,55 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort do platform <- getPlatform dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc infos case (ddef,dd) of -- note: m = raw, n = scan - (DataDefValue _ _ _, DataDefValue m n a) + (DataDefValue _, DataDefValue vr) -> if (hasKindStarResult (getKind typeResult)) - then return (DataDefValue m n a) + then return (DataDefValue vr) else do addError range (text "Type" <+> nameDoc <+> text "is declared as a value type but does not have a value kind ('V').") -- should never happen? return DataDefNormal - (DataDefValue _ _ _, DataDefNormal) + (DataDefValue _, DataDefNormal) -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? return DataDefNormal - (DataDefAuto, DataDefValue m n a) - -> if ((m + (n*sizeField platform)) <= 3*(sizeField platform) + (DataDefAuto, DataDefValue vr) + -> if (valueReprSize vr <= 3*(sizeField platform) && hasKindStarResult (getKind typeResult) && (sort /= Retractive)) then -- trace ("default to value: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefValue m n a) + return (DataDefValue vr) else -- trace ("default to reference: " ++ show name ++ ": " ++ show (m,n)) $ return (DataDefNormal) _ -> return DataDefNormal + let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef1 vis doc + dataInfo <- case ddef1 of + DataDefValue (ValueRepr m n a _) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) + -> -- add extra required tag field to the size + -- todo: recalculate the constructor sizes as well! + do platform <- getPlatform + let ddef2 = DataDefValue (valueReprNew platform m (n+1) a) + return $ dataInfo0{ dataInfoDef = ddef2 } + _ -> return dataInfo0 + -- trace (showTypeBinder newtp') $ addRangeInfo range (Decl (show sort) (getName newtp') (mangleTypeName (getName newtp'))) - let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef' vis doc return (Core.Data dataInfo isExtend) where conVis (UserCon name exist params result rngName rng vis _) = vis toDefValues :: Platform -> Bool -> Name -> Doc -> [ConInfo] -> KInfer DataDef toDefValues platform isVal qname nameDoc conInfos - = do ddefs <- mapM (toDefValue nameDoc) conInfos + = do let ddefs = map conInfoValueRepr conInfos ddef <- maxDataDefs platform qname isVal nameDoc ddefs case ddef of - DataDefValue 0 0 0 -- enumeration + DataDefValue (ValueRepr 0 0 0 _) -- enumeration -> let n = length conInfos - in if (n < 256) then return $ DataDefValue 1 0 1 -- uint8_t - else if (n < 65536) then return $ DataDefValue 2 0 2 -- uint16_t - else return $ DataDefValue 4 0 4 -- uint32_t + in if (n < 256) then return $ DataDefValue (ValueRepr 1 0 1 1) -- uint8_t + else if (n < 65536) then return $ DataDefValue (ValueRepr 2 0 2 2) -- uint16_t + else return $ DataDefValue (ValueRepr 4 0 4 4) -- uint32_t _ -> return ddef - toDefValue :: Doc -> ConInfo -> KInfer (Int,Int) - toDefValue nameDoc con - = do ddefs <- mapM (typeDataDef lookupDataInfo . snd) (conInfoParams con) - dd <- sumDataDefs nameDoc ddefs - -- trace ("datadefs: " ++ show nameDoc ++ "." ++ show (conInfoName con) ++ ": " ++ show ddefs ++ " to " ++ show dd) $ - return dd - + -- note: (m = raw, n = scan) - maxDataDefs :: Platform -> Name -> Bool -> Doc -> [(Int,Int)] -> KInfer DataDef + maxDataDefs :: Platform -> Name -> Bool -> Doc -> [ValueRepr] -> KInfer DataDef maxDataDefs platform name False nameDoc [] -- reference type, no constructors = return DataDefNormal maxDataDefs platform name True nameDoc [] -- primitive abstract value type with no constructors @@ -921,68 +924,31 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then do addWarning range (text "Type:" <+> nameDoc <+> text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform)) return (sizePtr platform) else return size - return (DataDefValue m 0 m) - maxDataDefs platform name isVal nameDoc [(m,n)] -- singleton value - = return (DataDefValue m n m) - maxDataDefs platform name isVal nameDoc (dd:dds) - = do dd2 <- maxDataDefs platform name isVal nameDoc dds - case (dd,dd2) of - ((0,0), DataDefValue m n a) -> return (DataDefValue m n a) - ((m,n), DataDefValue 0 0 a) -> return (DataDefValue m n a) - ((m1,0), DataDefValue m2 0 a) -> return (DataDefValue (max m1 m2) 0 a) - ((0,n1), DataDefValue 0 n2 a) -> return (DataDefValue 0 (max n1 n2) a) - ((m1,n1), DataDefValue m2 n2 a) - -- TODO: mixed raw is ok? - -- | m1 == m2 -> return (DataDefValue m1 (max n1 n2)) - | n1 == n2 -> return (DataDefValue (max m1 m2) n1 a) + return (DataDefValue (valueReprNew platform m 0 m)) + maxDataDefs platform name isVal nameDoc [vr] -- singleton value + = return (DataDefValue vr) + maxDataDefs platform name isVal nameDoc (vr:vrs) + = do dd <- maxDataDefs platform name isVal nameDoc vrs + case (vr,dd) of + (ValueRepr 0 0 _ _, DataDefValue v) -> return (DataDefValue v) + (v, DataDefValue (ValueRepr 0 0 _ _)) -> return (DataDefValue v) + (ValueRepr m1 0 a1 _, DataDefValue (ValueRepr m2 0 a2 _)) + -> return (DataDefValue (valueReprNew platform (max m1 m2) 0 (max a1 a2))) + (ValueRepr 0 n1 a1 _, DataDefValue (ValueRepr 0 n2 a2 _)) + -> return (DataDefValue (valueReprNew platform 0 (max n1 n2) (max a1 a2))) + (ValueRepr m1 n1 a1 _, DataDefValue (ValueRepr m2 n2 a2 _)) + -- equal scan fields + | n1 == n2 -> return (DataDefValue (valueReprNew platform (max m1 m2) n1 (max a1 a2))) + -- non-equal scan fields | otherwise -> do if (isVal) - then -- addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors which varying raw types and regular types." <-> - -- text "hint: value types with multiple constructors must all use the same number of regular types when mixed with raw types (use 'box' to use a raw type as a regular type).") - addError range (text "type:" <+> nameDoc <+> text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + then addError range (text "type:" <+> nameDoc <+> text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") else addWarning range (text "type:" <+> nameDoc <+> text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) _ -> return DataDefNormal - sumDataDefs :: Doc -> [DataDef] -> KInfer (Int,Int) - sumDataDefs nameDoc ddefs - = walk 0 0 ddefs - where - walk m n [] = return (m,n) - walk m n (dd:dds) - = do case dd of - DataDefValue m1 n1 _ - -> do if (m1 > 0 && n1 > 0) -- mixed raw and scan fields? - then mapM_ (checkNoClash nameDoc m1 n1) dds - else return () - walk (alignedAdd m m1) (n + n1) dds - _ -> walk m (n + 1) dds - - checkNoClash :: Doc -> Int -> Int -> DataDef -> KInfer () - checkNoClash nameDoc m1 n1 dd - = case dd of - DataDefValue m2 n2 _ | m2 > 0 && n2 > 0 - -> do addError range (text "Type:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> - text ("hint: use 'box' on either field to make it a non-value type.")) - _ -> return () - - - -- get the DataDef for a previous type - typeDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m DataDef - typeDataDef lookupDataInfo tp - = case expandSyn tp of - TCon (TypeCon name _) - -> do mbdi <- lookupDataInfo name - case mbdi of - Nothing -> failure ("Kind.Infer.resolve data def: unknown type: " ++ show name); - Just di -> return (dataInfoDef di) - TApp t _ -> typeDataDef lookupDataInfo t - TForall _ _ t -> typeDataDef lookupDataInfo t - _ -> return DataDefNormal - - occursNegativeCon :: [Name] -> ConInfo -> Bool occursNegativeCon names conInfo = let (_,_,rho) = splitPredType (conInfoType conInfo) @@ -1051,7 +1017,7 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id addRangeInfo rng (Decl "con" qname (mangleConName qname)) addRangeInfo rngName (Id qname (NICon scheme) True) let fields = map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params')) - (orderedFields,size,scanCount,alignment) <- orderConFields rng name isOpen fields + (orderedFields,vrepr) <- orderConFields rng name isOpen fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars fields @@ -1060,7 +1026,7 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id (map (binderNameRange . snd) params') (map fst params') isSingleton - orderedFields size scanCount alignment + orderedFields vrepr vis doc) @@ -1069,13 +1035,13 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id --------------------------------------------------------- -- order constructor fields of constructors with raw field so the regular fields come first to be scanned. --- return the ordered fields, the byte size of the allocation, and the scan count (including tags)} +-- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) -- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes -orderConFields :: Range -> Name -> Bool -> [(Name,Type)] -> KInfer ([(Name,Type)],Int,Int,Int) +orderConFields :: Range -> Name -> Bool -> [(Name,Type)] -> KInfer ([(Name,Type)],ValueRepr) orderConFields range cname isOpen fields = do visit ([], [], [], if isOpen then 1 else 0, 0) fields where - visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> KInfer ([(Name,Type)],Int,Int,Int) + visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> KInfer ([(Name,Type)],ValueRepr) visit (rraw, rmixed, rscan, scanCount0, alignment0) [] = do when (length rmixed > 1) $ do cs <- getColorScheme @@ -1084,15 +1050,14 @@ orderConFields range cname isOpen fields text ("hint: use 'box' on either field to make it a non-value type.")) platform <- getPlatform let -- scancount and size before any mixed and raw fields - preSize = scanCount0 * sizeField platform + preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) -- if there is a mixed value member (with scan fields) we may need to add padding scan fields (!) -- (or otherwise the C compiler may insert uninitialized padding) (padding,mixedScan) = case rmixed of ((_,_,scan,ralign):_) - -> let headerSize = 8 -- always 64-bit (?) - padSize = (headerSize + preSize) `mod` ralign + -> let padSize = preSize `mod` ralign padCount = padSize `div` sizeField platform in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ ([((newHiddenName ("padding" ++ show i),typeInt),sizeField platform,1,sizeField platform) | i <- [1..padCount]] @@ -1106,12 +1071,15 @@ orderConFields range cname isOpen fields restSizes = [size | (_field,size,_scan,_align) <- rest] restFields= [field | (field,_size,_scan,_align) <- rest] size = alignedSum preSize restSizes - return (reverse rscan ++ restFields, size, scanCount, alignment) + rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) + vrepr = valueReprNew platform rawSize scanCount alignment + -- trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ + return (reverse rscan ++ restFields, vrepr) visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) = do mDataDef <- getDataDef tp case mDataDef of - Just (DataDefValue raw scan align) + Just (DataDefValue (ValueRepr raw scan align _)) -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors let alignment = max align alignment0 in if (raw > 0 && scan > 0) @@ -1126,8 +1094,8 @@ orderConFields range cname isOpen fields -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype insertRaw :: (Name,Type) -> Int -> Int -> Int -> [((Name,Type),Int,Int,Int)] -> [((Name,Type),Int,Int,Int)] insertRaw field raw scan align ((f,r,s,a):rs) - | align <= a && raw <= r = (field,raw,scan,align):(f,r,s,a):rs - | otherwise = (f,r,s,a):insertRaw field raw scan align rs + | align <= a = (field,raw,scan,align):(f,r,s,a):rs + | otherwise = (f,r,s,a):insertRaw field raw scan align rs insertRaw field raw scan align [] = [(field,raw,scan,align)] diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 049e4ceed..810b2b322 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -563,7 +563,7 @@ structDecl dvis = (try $ do (vis,dvis,rng) <- do{ rng <- keyword "abstract"; return (Public,Private,rng) } <|> do{ (vis,rng) <- visibility dvis; return (vis,vis,rng) } - ddef <- do { specialId "value"; return (DataDefValue 0 0 0) } + ddef <- do { specialId "value"; return (DataDefValue valueReprZero) } <|> do { specialId "reference"; return DataDefNormal } <|> do { return DataDefAuto } (trng,doc) <- dockeyword "struct" @@ -607,7 +607,7 @@ typeDeclKind try( do (ddef,isExtend) <- do { specialId "open"; return (DataDefOpen, False) } <|> do { specialId "extend"; return (DataDefOpen, True) } - <|> do { specialId "value"; return (DataDefValue 0 0 0, False) } + <|> do { specialId "value"; return (DataDefValue valueReprZero, False) } <|> do { specialId "reference"; return (DataDefNormal, False) } <|> return (DataDefAuto, False) (rng,doc) <- dockeyword "type" diff --git a/src/Type/Pretty.hs b/src/Type/Pretty.hs index a4ab684bf..82b075f74 100644 --- a/src/Type/Pretty.hs +++ b/src/Type/Pretty.hs @@ -244,7 +244,7 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki else case datadef of DataDefRec -> text "recursive " DataDefOpen -> text "open " - DataDefValue m n a -> text ("value{" ++ show m ++ "," ++ show n ++ "," ++ show a ++ "} ") + DataDefValue v -> text ("value" ++ show v ++ " ") _ -> empty) <.> (case datakind of Inductive -> keyword env "type" @@ -260,7 +260,7 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki else empty)) prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields scheme sort range paramRanges paramVis singleton - orderedFields size scanCount alignment vis doc) + orderedFields vrepr vis doc) = if (publicOnly && isPrivate vis) then empty else (prettyComment env0 doc $ (if publicOnly then empty else ppVis env0 vis) <.> @@ -270,7 +270,7 @@ prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields sche (if null fields then empty else parens (commaSep (map (ppField env) (zip paramVis fields)))) <.> - (text "{" <.> pretty size <.> comma <.> pretty scanCount <.> comma <.> pretty alignment <.> text "}") + (text (show vrepr)) <+> text ":" <+> ppType env scheme <.> semi) where ppField env (fvis,(name,tp)) diff --git a/src/Type/Type.hs b/src/Type/Type.hs index 495e05683..70afacd55 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -13,6 +13,7 @@ module Type.Type (-- * Types , Flavour(..) , DataInfo(..), DataKind(..), ConInfo(..), SynInfo(..) , dataInfoIsRec, dataInfoIsOpen, dataInfoIsLiteral + , conInfoSize -- Predicates , splitPredType, shallowSplitPreds, shallowSplitVars , predType @@ -77,7 +78,7 @@ import Common.NamePrim import Common.Range import Common.Id import Common.Failure -import Common.Syntax( Visibility, DataKind(..), DataDef(..), dataDefIsRec, dataDefIsOpen ) +import Common.Syntax( Visibility, DataKind(..), DataDef(..), ValueRepr(..), dataDefIsRec, dataDefIsOpen, valueReprSize ) import Kind.Kind {-------------------------------------------------------------------------- @@ -202,9 +203,7 @@ data ConInfo = ConInfo{ conInfoName :: Name , conInfoParamVis :: [Visibility] , conInfoSingleton :: Bool -- ^ is this the only constructor of this type? , conInfoOrderedParams :: [(Name,Type)] -- ^ fields ordered by size - , conInfoSize :: Int - , conInfoScanFields :: Int - , conInfoAlignment :: Int + , conInfoValueRepr :: ValueRepr , conInfoVis :: Visibility , conInfoDoc :: String } @@ -213,6 +212,11 @@ instance Show ConInfo where show info = show (conInfoName info) +conInfoSize :: ConInfo -> Int +conInfoSize conInfo + = valueReprSize (conInfoValueRepr conInfo) + + -- | A type synonym is quantified by type parameters data SynInfo = SynInfo{ synInfoName :: Name , synInfoKind :: Kind @@ -226,6 +230,8 @@ data SynInfo = SynInfo{ synInfoName :: Name deriving Show + + {-------------------------------------------------------------------------- Accessors --------------------------------------------------------------------------} From d78d3a9131b366e12a524a314661ddbfafabfe46 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 20 Feb 2023 13:29:08 -0800 Subject: [PATCH 137/233] wip: improve con field ordering --- koka.cabal | 1 + src/Backend/C/FromCore.hs | 42 +++++++++----- src/Backend/C/ParcReuse.hs | 8 +-- src/Common/Syntax.hs | 18 +++--- src/Kind/Infer.hs | 102 +++----------------------------- src/Kind/Repr.hs | 116 +++++++++++++++++++++++++++++++++++++ test/parc/parc22.kk.out | 14 +++-- 7 files changed, 172 insertions(+), 129 deletions(-) create mode 100644 src/Kind/Repr.hs diff --git a/koka.cabal b/koka.cabal index ce7e76ea7..d398cf6ac 100644 --- a/koka.cabal +++ b/koka.cabal @@ -87,6 +87,7 @@ executable koka Kind.Kind Kind.Newtypes Kind.Pretty + Kind.Repr Kind.Synonym Kind.Unify Lib.JSON diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 8a486ddc2..76d957a5d 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -22,6 +22,7 @@ import qualified Data.Set as S import Common.File( normalizeWith, startsWith, endsWith ) import Kind.Kind import Kind.Newtypes +import Kind.Repr( orderConFields ) import Type.Type import Type.TypeVar import Type.Kind( getKind ) @@ -42,9 +43,9 @@ import Core.Pretty import Core.CoreVar import Core.Borrowed ( Borrowed, borrowedExtendICore ) -import Backend.C.Parc -import Backend.C.ParcReuse -import Backend.C.ParcReuseSpec +import Backend.C.Parc( parcCore ) +import Backend.C.ParcReuse ( parcReuseCore ) +import Backend.C.ParcReuseSpec (parcReuseSpecialize ) import Backend.C.Box type CommentDoc = Doc @@ -478,10 +479,15 @@ genTypeDefPost (Data info isExtend) -- order fields of constructors to have their scan fields first let conInfoReprs = zip (dataInfoConstrs info) conReprs conInfos <- mapM (\(conInfo,conRepr) -> do -- should never fail as mixed raw/scan is checked in kindInfer + {- newtypes <- getNewtypes platform <- getPlatform let (fields,size,scanCount) = orderConFieldsEx platform newtypes (dataRepr == DataOpen) (conInfoParams conInfo) + -} + let fields = conInfoOrderedParams conInfo + scanCount = valueReprScanCount (conInfoValueRepr conInfo) return (conInfo,conRepr,fields,scanCount)) conInfoReprs + let maxScanCount = maxScanCountOf conInfos minScanCount = minScanCountOf conInfos @@ -498,7 +504,7 @@ genTypeDefPost (Data info isExtend) return () else if (dataRepr == DataEnum || not (dataReprIsValue dataRepr)) then return () - else emitToH $ if (hasTagField dataRepr) + else emitToH $ if (needsTagField dataRepr) then ppVis (dataInfoVis info) <.> text "kk_struct_packed" <+> ppName name <.> text "_s" <+> block (text "kk_value_tag_t _tag;" <-> text "union" <+> block (vcat ( @@ -619,7 +625,7 @@ ppConTag con conRepr dataRepr ConSingleton{} | dataRepr == DataAsMaybe -> text "KK_TAG_NOTHING" ConAsJust{} -> text "KK_TAG_JUST" -- ConSingleton{} | dataRepr == DataAsList -> text "datatype_from_enum(" <.> pretty (conTag conRepr) <.> text ")" -- ppName ((conInfoName con)) - _ | hasTagField dataRepr -> text "kk_value_tag(" <.> pretty (conTag conRepr) <.> text ")" + _ | needsTagField dataRepr -> text "kk_value_tag(" <.> pretty (conTag conRepr) <.> text ")" _ -> text "(kk_tag_t)" <.> parens (pretty (conTag conRepr)) @@ -659,7 +665,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount assignField f (name,tp) = f (ppDefName name) <+> text "=" <+> ppDefName name <.> semi in if (dataReprIsValue dataRepr) then vcat(--[ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi] - (if (hasTagField dataRepr) + (if (needsTagField dataRepr) then [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi , tmp <.> text "._tag =" <+> ppConTag con conRepr dataRepr <.> semi] ++ map (assignField (\fld -> tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> fld)) conFields @@ -797,8 +803,8 @@ genBox name info dataRepr ) _ -> case dataInfoDef info of DataDefValue (ValueRepr raw scancount alignment _) - -> let -- extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors - docScanCount = {- if (hasTagField dataRepr) + -> let -- extra = if (needsTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors + docScanCount = {- if (needsTagField dataRepr) then ppName name <.> text "_scan_count" <.> arguments [text "_x"] else -} pretty (scancount {- + extra -}) <+> text "/* scan count */" @@ -913,7 +919,7 @@ genHole name info dataRepr {- genScanFields :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () -genScanFields name info dataRepr conInfos | not (hasTagField dataRepr) +genScanFields name info dataRepr conInfos | not (needsTagField dataRepr) = return () genScanFields name info dataRepr conInfos = emitToH $ @@ -976,7 +982,7 @@ genDupDropValue :: Bool -> DataRepr -> Int -> [Doc] genDupDropValue isDup dataRepr 0 = [] -- genDupDropValue isDup DataStructAsMaybe 1 -- todo: maybe specialize? genDupDropValue isDup dataRepr scanCount - = [text "kk_box_t* _fields = (kk_box_t*)" <.> text (if hasTagField dataRepr then "&_x._cons._fields" else "&_x") <.> semi] + = [text "kk_box_t* _fields = (kk_box_t*)" <.> text (if needsTagField dataRepr then "&_x._cons._fields" else "&_x") <.> semi] ++ [text "kk_box_" <.> text (if isDup then "dup" else "drop") <.> arguments [text "_fields[" <.> pretty (i-1) <.> text "]"] <.> semi | i <- [1..scanCount]] @@ -1021,7 +1027,7 @@ genDupDropFields :: Bool -> DataRepr -> ConInfo -> [(Name,Type)] -> [Doc] genDupDropFields isDup dataRepr con conFields = map (\doc -> doc <.> semi) $ concat $ [genDupDropCall isDup tp - ((if (hasTagField dataRepr) then text "_x._cons." <.> ppDefName (conInfoName con) else text "_x") + ((if (needsTagField dataRepr) then text "_x._cons." <.> ppDefName (conInfoName con) else text "_x") <.> dot <.> ppName name) | (name,tp) <- conFields] @@ -1162,9 +1168,17 @@ genLambda params eff body funTpName = postpend "_t" funName structDoc = text "struct" <+> ppName funTpName freeVars = [(nm,tp) | (TName nm tp) <- tnamesList (freeLocals (Lam params eff body))] - newtypes <- getNewtypes + platform <- getPlatform - let (fields,_,scanCount) = orderConFieldsEx platform newtypes False freeVars + let emitError makeMsg = do env <- getEnv + let lam = text (show (cdefName env) ++ ":") + let msg = show (makeMsg lam) + failure ("Backend.C.genLambda: " ++ msg) + getDataInfo name = do newtypes <- getNewtypes + return (newtypesLookupAny name newtypes) + (fields,vrepr) <- orderConFields emitError getDataInfo platform False freeVars + + let scanCount = valueReprScanCount vrepr fieldDocs = [ppType tp <+> ppName name | (name,tp) <- fields] tpDecl = text "kk_struct_packed" <+> ppName funTpName <+> block ( vcat ([text "struct kk_function_s _base;"] ++ @@ -1595,7 +1609,7 @@ genPatternTest doTest eagerPatBind (exprDoc,pattern) valTest conName conInfo dataRepr = --do let next = genNextPatterns (exprDoc) (typeOf tname) patterns -- return [(test [conTestName conInfo <.> parens exprDoc],[assign],next)] - do let selectOp = if (hasTagField dataRepr) + do let selectOp = if (needsTagField dataRepr) then "._cons." ++ show (ppDefName (getName conName)) ++ "." else "." next = genNextPatterns (\self fld -> self <.> text selectOp <.> fld) exprDoc (typeOf tname) patterns diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 74b1ab926..6032ba3a8 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -596,7 +596,7 @@ getRuConSize dataType -> let cis = dataInfoConstrs dataInfo sizes = map conInfoSize cis in case sizes of - (s:ss) | all (==s) ss -> return $ Just (valueReprSize vrepr, valScanCount vrepr) + (s:ss) | all (==s) ss -> return $ Just (valueReprSize vrepr, valueReprScanCount vrepr) _ -> return Nothing _ -> return Nothing _ -> return Nothing @@ -658,14 +658,14 @@ orderConFieldsEx platform newtypes isOpen fields = let mDataDefRepr = newtypesDataDefRepr newtypes tp in case mDataDefRepr of Just (DataDefValue (ValueRepr raw scan alignment _), dataRepr) - -> let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors + -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) -- but we count them to be sure (and for function data) - visit (rraw, (field,raw):rmixed, rscan, scanCount + scan + extra) fs + visit (rraw, (field,raw):rmixed, rscan, scanCount + scan) fs else if (raw > 0) then visit (insertRaw field raw rraw, rmixed, rscan, scanCount) fs - else visit (rraw, rmixed, field:rscan, scanCount + scan + extra) fs + else visit (rraw, rmixed, field:rscan, scanCount + scan) fs _ -> visit (rraw, rmixed, field:rscan, scanCount + 1) fs -- insert raw fields in order of size so they align to the smallest total size in a datatype diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 8cad5dadf..23d4966dd 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -21,7 +21,7 @@ module Common.Syntax( Visibility(..) , DataDef(..) , dataDefIsRec, dataDefIsOpen, dataDefIsValue, dataDefSize , ValueRepr(..) - , valueReprIsMixed, valueReprIsRaw, valueReprNew, valueReprZero, valueReprSize + , valueReprIsMixed, valueReprIsRaw, valueReprNew, valueReprZero , HandlerSort(..) , isHandlerInstance, isHandlerNormal , OperationSort(..), readOperationSort @@ -216,7 +216,7 @@ dataDefIsValue ddef dataDefSize :: Platform -> DataDef -> Int dataDefSize platform ddef = case ddef of - DataDefValue v -> valSize v + DataDefValue v -> valueReprSize v _ -> sizeField platform @@ -224,10 +224,10 @@ dataDefSize platform ddef Definition kind --------------------------------------------------------------------------} -data ValueRepr = ValueRepr{ valRawSize :: !Int {- size in bytes -}, - valScanCount :: !Int {- count of scannable fields -}, - valAlignment :: !Int {- minimal alignment -}, - valSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} +data ValueRepr = ValueRepr{ valueReprRawSize :: !Int {- size in bytes -}, + valueReprScanCount :: !Int {- count of scannable fields -}, + valueReprAlignment :: !Int {- minimal alignment -}, + valueReprSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} } deriving Eq @@ -235,14 +235,12 @@ instance Show ValueRepr where show (ValueRepr raw scan align full) = "{" ++ concat (intersperse "," (map show [raw,scan,align,full])) ++ "}" -valueReprSize :: ValueRepr -> Int -valueReprSize v = valSize v valueReprIsMixed :: ValueRepr -> Bool -valueReprIsMixed v = (valRawSize v > 0) && (valScanCount v > 0) +valueReprIsMixed v = (valueReprRawSize v > 0) && (valueReprScanCount v > 0) valueReprIsRaw :: ValueRepr -> Bool -valueReprIsRaw v = (valRawSize v > 0) && (valScanCount v == 0) +valueReprIsRaw v = (valueReprRawSize v > 0) && (valueReprScanCount v == 0) valueReprNew :: Platform -> Int -> Int -> Int -> ValueRepr valueReprNew platform rawSize scanCount align diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 05dd26b29..20bc1af99 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -20,7 +20,7 @@ -} ----------------------------------------------------------------------------- -module Kind.Infer (inferKinds) where +module Kind.Infer (inferKinds ) where import Lib.Trace -- import Type.Pretty @@ -51,7 +51,7 @@ import Kind.Assumption import Kind.Constructors import Kind.Newtypes import Kind.Synonym - +import Kind.Repr( orderConFields ) import Type.Type import Type.Assumption import Type.TypeVar( tvsIsEmpty, ftv, subNew, (|->), tvsMember, tvsList ) @@ -1017,7 +1017,11 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id addRangeInfo rng (Decl "con" qname (mangleConName qname)) addRangeInfo rngName (Id qname (NICon scheme) True) let fields = map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params')) - (orderedFields,vrepr) <- orderConFields rng name isOpen fields + emitError makeMsg = do cs <- getColorScheme + let nameDoc = color (colorCons cs) (pretty name) + addError rng (makeMsg nameDoc) + platform <- getPlatform + (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform isOpen fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars fields @@ -1030,98 +1034,6 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id vis doc) ---------------------------------------------------------- --- Determine the size of a constructor ---------------------------------------------------------- - --- order constructor fields of constructors with raw field so the regular fields come first to be scanned. --- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) --- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes -orderConFields :: Range -> Name -> Bool -> [(Name,Type)] -> KInfer ([(Name,Type)],ValueRepr) -orderConFields range cname isOpen fields - = do visit ([], [], [], if isOpen then 1 else 0, 0) fields - where - visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> KInfer ([(Name,Type)],ValueRepr) - visit (rraw, rmixed, rscan, scanCount0, alignment0) [] - = do when (length rmixed > 1) $ - do cs <- getColorScheme - let nameDoc = color (colorCons cs) (pretty cname) - addError range (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> - text ("hint: use 'box' on either field to make it a non-value type.")) - platform <- getPlatform - let -- scancount and size before any mixed and raw fields - preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) - - -- if there is a mixed value member (with scan fields) we may need to add padding scan fields (!) - -- (or otherwise the C compiler may insert uninitialized padding) - (padding,mixedScan) - = case rmixed of - ((_,_,scan,ralign):_) - -> let padSize = preSize `mod` ralign - padCount = padSize `div` sizeField platform - in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ - ([((newHiddenName ("padding" ++ show i),typeInt),sizeField platform,1,sizeField platform) | i <- [1..padCount]] - ,scan + padCount) - [] -> ([],0) - - -- calculate the rest now - scanCount = scanCount0 + mixedScan - alignment = if scanCount > 0 then max alignment0 (sizeField platform) else alignment0 - rest = padding ++ rmixed ++ reverse rraw - restSizes = [size | (_field,size,_scan,_align) <- rest] - restFields= [field | (field,_size,_scan,_align) <- rest] - size = alignedSum preSize restSizes - rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) - vrepr = valueReprNew platform rawSize scanCount alignment - -- trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ - return (reverse rscan ++ restFields, vrepr) - - visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) - = do mDataDef <- getDataDef tp - case mDataDef of - Just (DataDefValue (ValueRepr raw scan align _)) - -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors - let alignment = max align alignment0 in - if (raw > 0 && scan > 0) - then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) - -- but we count them to be sure (and for function data) - visit (rraw, (field,raw,scan,align):rmixed, rscan, scanCount, alignment) fs - else if (raw > 0) - then visit (insertRaw field raw scan align rraw, rmixed, rscan, scanCount, alignment) fs - else visit (rraw, rmixed, field:rscan, scanCount + scan, alignment) fs - _ -> visit (rraw, rmixed, field:rscan, scanCount + 1, alignment0) fs - - -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype - insertRaw :: (Name,Type) -> Int -> Int -> Int -> [((Name,Type),Int,Int,Int)] -> [((Name,Type),Int,Int,Int)] - insertRaw field raw scan align ((f,r,s,a):rs) - | align <= a = (field,raw,scan,align):(f,r,s,a):rs - | otherwise = (f,r,s,a):insertRaw field raw scan align rs - insertRaw field raw scan align [] - = [(field,raw,scan,align)] - - - --- | Return the DataDef for a type. --- This may be 'Nothing' for abstract types. -getDataDef :: Type -> KInfer (Maybe DataDef) -getDataDef tp - = case extractDataDefType tp of - Nothing -> return $ Just DataDefNormal - Just name | name == nameTpBox -> return $ Just DataDefNormal - Just name -> do mdi <- lookupDataInfo name - case mdi of - Nothing -> return Nothing - Just di -> return $ Just (dataInfoDef di) - where - extractDataDefType :: Type -> Maybe Name - extractDataDefType tp - = case expandSyn tp of - TApp t _ -> extractDataDefType t - TForall _ _ t -> extractDataDefType t - TCon tc -> Just (typeConName tc) - _ -> Nothing - - --------------------------------------------------------- -- --------------------------------------------------------- diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs new file mode 100644 index 000000000..7af14c914 --- /dev/null +++ b/src/Kind/Repr.hs @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- +{- + +-} +----------------------------------------------------------------------------- +module Kind.Repr( orderConFields ) where + +import Control.Monad( when ) +import Lib.PPrint +import Common.Name +import Common.NamePrim +import Common.Syntax +import Common.Failure +import Type.Type + +--------------------------------------------------------- +-- Determine the size of a constructor +--------------------------------------------------------- + +-- order constructor fields of constructors with raw field so the regular fields come first to be scanned. +-- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) +-- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes +orderConFields :: Monad m => ((Doc -> Doc) -> m ()) -> (Name -> m (Maybe DataInfo)) -> Platform + -> Bool -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) +orderConFields emitError getDataInfo platform isOpen fields + = do visit ([], [], [], if isOpen then 1 else 0, 0) fields + where + -- visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) + visit (rraw, rmixed, rscan, scanCount0, alignment0) [] + = do when (length rmixed > 1) $ + do emitError (\nameDoc -> (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + text ("hint: use 'box' on either field to make it a non-value type."))) + {- + cs <- getColorScheme + let nameDoc = color (colorCons cs) (pretty cname) + addError range (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + text ("hint: use 'box' on either field to make it a non-value type.")) + -} + let -- scancount and size before any mixed and raw fields + preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) + + -- if there is a mixed value member (with scan fields) we may need to add padding scan fields (!) + -- (or otherwise the C compiler may insert uninitialized padding) + (padding,mixedScan) + = case rmixed of + ((_,_,scan,ralign):_) + -> let padSize = preSize `mod` ralign + padCount = padSize `div` sizeField platform + in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ + ([((newHiddenName ("padding" ++ show i),typeInt),sizeField platform,1,sizeField platform) | i <- [1..padCount]] + ,scan + padCount) + [] -> ([],0) + + -- calculate the rest now + scanCount = scanCount0 + mixedScan + alignment = if scanCount > 0 then max alignment0 (sizeField platform) else alignment0 + rest = padding ++ rmixed ++ reverse rraw + restSizes = [size | (_field,size,_scan,_align) <- rest] + restFields= [field | (field,_size,_scan,_align) <- rest] + size = alignedSum preSize restSizes + rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) + vrepr = valueReprNew platform rawSize scanCount alignment + -- trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ + return (reverse rscan ++ restFields, vrepr) + + visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) + = do mDataDef <- getDataDef getDataInfo tp + case mDataDef of + Just (DataDefValue (ValueRepr raw scan align _)) + -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors + let alignment = max align alignment0 in + if (raw > 0 && scan > 0) + then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) + -- but we count them to be sure (and for function data) + visit (rraw, (field,raw,scan,align):rmixed, rscan, scanCount, alignment) fs + else if (raw > 0) + then visit (insertRaw field raw scan align rraw, rmixed, rscan, scanCount, alignment) fs + else visit (rraw, rmixed, field:rscan, scanCount + scan, alignment) fs + _ -> visit (rraw, rmixed, field:rscan, scanCount + 1, alignment0) fs + + -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype + insertRaw :: (Name,Type) -> Int -> Int -> Int -> [((Name,Type),Int,Int,Int)] -> [((Name,Type),Int,Int,Int)] + insertRaw field raw scan align ((f,r,s,a):rs) + | align <= a = (field,raw,scan,align):(f,r,s,a):rs + | otherwise = (f,r,s,a):insertRaw field raw scan align rs + insertRaw field raw scan align [] + = [(field,raw,scan,align)] + + + +-- | Return the DataDef for a type. +-- This may be 'Nothing' for abstract types. +getDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m (Maybe DataDef) +getDataDef lookupDI tp + = case extractDataDefType tp of + Nothing -> return $ Just DataDefNormal + Just name | name == nameTpBox -> return $ Just DataDefNormal + Just name -> do mdi <- lookupDI name + case mdi of + Nothing -> return Nothing + Just di -> return $ Just (dataInfoDef di) + where + extractDataDefType :: Type -> Maybe Name + extractDataDefType tp + = case expandSyn tp of + TApp t _ -> extractDataDefType t + TForall _ _ t -> extractDataDefType t + TCon tc -> Just (typeConName tc) + _ -> Nothing + diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index a234ddd93..c6600f479 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -2,7 +2,7 @@ module parc/parc22 import std/core/types = std/core/types = ""; import std/core = std/core = ""; pub rec type parc/parc22/hello { - pub con parc/parc22/World(i: int) : (i : int) -> parc/parc22/hello; + pub con parc/parc22/World(i: int){0,1,8,8} : (i : int) -> parc/parc22/hello; }; // Automatically generated. Retrieves the `i` constructor field of the `:hello` type. pub fun i : (^ hello : parc/parc22/hello) -> int @@ -16,7 +16,11 @@ pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/he = fn(.this: parc/parc22/hello, i0: optional){ parc/parc22/World((match (i0) { (std/core/types/Optional(((.skip std/core/types/.Box((.i: int)) : .Box ) as .box: .Box)) : optional ) - -> val _ : () + -> val _ : int + = std/core/types/.dup(.i); + val _ : () + = std/core/types/.drop(i0); + val _ : () = std/core/types/.drop(.this, (std/core/int32(1))); .i; (.skip std/core/types/None() : (optional) ) @@ -43,9 +47,7 @@ pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/he }; pub fun f : (h : parc/parc22/hello) -> parc/parc22/hello = fn(h: parc/parc22/hello){ - val .ru : reuse - = std/core/types/no-reuse(); val _ : () - = std/core/types/.assign-reuse(.ru, (std/core/types/.drop-reuse(h, (std/core/int32(1))))); - std/core/types/.alloc-at(.ru, (parc/parc22/World(2))); + = std/core/types/.drop(h, (std/core/int32(1))); + parc/parc22/World(2); }; \ No newline at end of file From 274456d216edd6b1d97ebbcffb80200750417573 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 20 Feb 2023 14:50:00 -0800 Subject: [PATCH 138/233] improved con size calculation for reuse --- src/Backend/C/Box.hs | 4 +- src/Backend/C/FromCore.hs | 8 ++-- src/Backend/C/Parc.hs | 21 ++++----- src/Backend/C/ParcReuse.hs | 33 ++++++------- src/Backend/CSharp/FromCore.hs | 66 +++++++++++++------------- src/Backend/JavaScript/FromCore.hs | 20 ++++---- src/Common/Syntax.hs | 32 +++++++++---- src/Core/Core.hs | 76 +++++++++++++++++------------- src/Core/Parse.hs | 4 +- src/Kind/Infer.hs | 33 +++++++------ src/Kind/Repr.hs | 4 +- src/Type/Infer.hs | 2 +- src/Type/Type.hs | 9 ++-- test/parc/parc22.kk.out | 2 +- 14 files changed, 166 insertions(+), 148 deletions(-) diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index 549ff9b21..994406177 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -390,14 +390,14 @@ patBox tpPat tpRes pat = PatCon (TName nameBoxCon (conInfoType boxConInfo)) [pat] boxConRepr [tpPat] [] tpRes boxConInfo True boxConRepr :: ConRepr -boxConRepr = ConSingle nameTpBox (DataSingle False) 0 +boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) 0 boxConInfo :: ConInfo boxConInfo = ConInfo nameBox nameTpBox [a] [] [(nameNil,TVar a)] tp Inductive rangeNull [] [Public] True [(nameNil,TVar a)] - (ValueRepr 0 1 1 0 {- size is wrong with knowing the platform ? -}) + (valueReprScan 1) {- size is wrong with knowing the platform ? -} Public "" where tp = TForall [a] [] (TFun [(nameNil,TVar a)] typeTotal typeBoxStar) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 76d957a5d..65a28a7b1 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -445,9 +445,9 @@ genTypeDefPre (Data info isExtend) -- generate the type declaration if (dataRepr == DataEnum) then let enumIntTp = case (dataInfoDef info) of - DataDefValue (ValueRepr 1 0 _ _) -> "uint8_t" - DataDefValue (ValueRepr 2 0 _ _) -> "uint16_t" - _ -> "uint32_t" + DataDefValue (ValueRepr 1 0 _) -> "uint8_t" + DataDefValue (ValueRepr 2 0 _) -> "uint16_t" + _ -> "uint32_t" ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> @@ -802,7 +802,7 @@ genBox name info dataRepr in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) _ -> case dataInfoDef info of - DataDefValue (ValueRepr raw scancount alignment _) + DataDefValue (ValueRepr raw scancount alignment) -> let -- extra = if (needsTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors docScanCount = {- if (needsTagField dataRepr) then ppName name <.> text "_scan_count" <.> arguments [text "_x"] diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index ac9b2d84d..4ef0978d8 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -48,8 +48,6 @@ import Core.CoreVar import Core.Pretty import Core.Borrowed -import Backend.C.ParcReuse( constructorSizeOf ) - -------------------------------------------------------------------------- -- Reference count transformation -------------------------------------------------------------------------- @@ -589,7 +587,7 @@ getBoxForm' :: Platform -> Newtypes -> Type -> BoxForm getBoxForm' platform newtypes tp = -- trace ("getBoxForm' of " ++ show (pretty tp)) $ case getDataDef' newtypes tp of - Just (DataDefValue (ValueRepr m 0 _ _)) -- 0 scan fields, m is size in bytes of raw fields + Just (DataDefValue (ValueRepr m 0 _)) -- 0 scan fields, m is size in bytes of raw fields -> -- trace " 0 scan fields" $ case extractDataDefType tp of Just name @@ -652,10 +650,10 @@ data ValueForm getValueForm' :: Newtypes -> Type -> Maybe ValueForm getValueForm' newtypes tp = case getDataDef' newtypes tp of - Just (DataDefValue (ValueRepr _ 0 _ _)) -> Just ValueAllRaw - Just (DataDefValue (ValueRepr 0 1 _ _)) -> Just ValueOneScan - Just (DataDefValue _) -> Just ValueOther - _ -> Nothing + Just (DataDefValue (ValueRepr _ 0 _)) -> Just ValueAllRaw + Just (DataDefValue (ValueRepr 0 1 _)) -> Just ValueOneScan + Just (DataDefValue _) -> Just ValueOther + _ -> Nothing getValueForm :: Type -> Parc (Maybe ValueForm) getValueForm tp = (`getValueForm'` tp) <$> getNewtypes @@ -837,11 +835,12 @@ getPlatform = platform <$> getEnv getConstructorScanFields :: TName -> ConRepr -> Parc Int getConstructorScanFields conName conRepr - = do platform <- getPlatform - newtypes <- getNewtypes - let (size,scan) = (constructorSizeOf platform newtypes conName conRepr) + = do return (valueReprScanCount (conValRepr conRepr)) + -- platform <- getPlatform + -- newtypes <- getNewtypes + -- let (size,scan) = -- (constructorSizeOf platform newtypes conName conRepr) -- parcTrace $ "get size " ++ show conName ++ ": " ++ show (size,scan) ++ ", " ++ show conRepr - return scan + -- return scan -- diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 6032ba3a8..06b47508e 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -11,10 +11,7 @@ -- constructor reuse analysis ----------------------------------------------------------------------------- -module Backend.C.ParcReuse ( parcReuseCore, - orderConFieldsEx, newtypesDataDefRepr, hasTagField, - constructorSizeOf - ) where +module Backend.C.ParcReuse ( parcReuseCore ) where import Lib.Trace (trace) import Control.Monad @@ -114,7 +111,7 @@ ruLam :: [TName] -> Effect -> Expr -> Reuse Expr ruLam pars eff body = fmap (Lam pars eff) $ withNone $ do forM_ pars $ \p -> do - msize <- getRuConSize (typeOf p) + msize <- getRuFixedDataSize (typeOf p) case msize of Just (size, scan) -> addDeconstructed (p, Nothing, size, scan) Nothing -> return () @@ -239,13 +236,14 @@ ruPattern varName pat@PatCon{patConName,patConPatterns,patConRepr,patTypeArgs,pa else do newtypes <- getNewtypes platform <- getPlatform -- use type scheme of con, not the instantiated type, to calculate the correct size - let (size, scan) = constructorSizeOf platform newtypes (TName (conInfoName ci) (conInfoType ci)) patConRepr + let (size,scan) = -- constructorSizeOf platform newtypes (TName (conInfoName ci) (conInfoType ci)) patConRepr + conReprAllocSizeScan platform patConRepr if size > 0 then do -- ruTrace $ "add for reuse: " ++ show (getName tname) ++ ": " ++ show size return ((varName, Just pat, size, scan):reuses) else return reuses ruPattern varName _ - = do msize <- getRuConSize (typeOf varName) + = do msize <- getRuFixedDataSize (typeOf varName) case msize of Just (size, scan) -> return [(varName, Nothing, size, scan)] Nothing -> return [] @@ -269,7 +267,7 @@ ruTryReuseCon cname repr conApp | "_noreuse" `isSuffixOf` nameId (conTypeName re ruTryReuseCon cname repr conApp = do newtypes <- getNewtypes platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr + let size = conReprAllocSize platform repr available <- getAvailable -- ruTrace $ "try reuse: " ++ show (getName cname) ++ ": " ++ show size case M.lookup size available of @@ -580,10 +578,10 @@ ruTrace msg -- | If all constructors of a type have the same shape, -- return the byte size and number of scan fields. -getRuConSize :: Type -> Reuse (Maybe (Int, Int)) -getRuConSize dataType +getRuFixedDataSize :: Type -> Reuse (Maybe (Int, Int)) +getRuFixedDataSize dataType = do newtypes <- getNewtypes - -- platform <- getPlatform + platform <- getPlatform let mdataName = extractDataName dataType if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName then return Nothing else do @@ -594,9 +592,9 @@ getRuConSize dataType in case ddef of DataDefValue vrepr -> let cis = dataInfoConstrs dataInfo - sizes = map conInfoSize cis + sizes = map (conInfoSize platform) cis in case sizes of - (s:ss) | all (==s) ss -> return $ Just (valueReprSize vrepr, valueReprScanCount vrepr) + (s:ss) | all (==s) ss -> return $ Just (valueReprSize platform vrepr, valueReprScanCount vrepr) _ -> return Nothing _ -> return Nothing _ -> return Nothing @@ -608,11 +606,8 @@ getRuConSize dataType TCon tc -> Just (typeConName tc) _ -> Nothing + {- -constructorSizeOf :: Platform -> ConInfo -> (Int,Int) -constructorSizeOf platform ci - = (conSize platform ci, conInfoScanFields ci) --} -- return the allocated size of a constructor. Return 0 for value types or singletons constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) @@ -657,7 +652,7 @@ orderConFieldsEx platform newtypes isOpen fields visit (rraw,rmixed,rscan,scanCount) (field@(name,tp) : fs) = let mDataDefRepr = newtypesDataDefRepr newtypes tp in case mDataDefRepr of - Just (DataDefValue (ValueRepr raw scan alignment _), dataRepr) + Just (DataDefValue (ValueRepr raw scan alignment), dataRepr) -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) @@ -701,3 +696,5 @@ hasTagField :: DataRepr -> Bool hasTagField DataStruct = True hasTagField DataStructAsMaybe = True hasTagField rep = False + +-} \ No newline at end of file diff --git a/src/Backend/CSharp/FromCore.hs b/src/Backend/CSharp/FromCore.hs index 410a6142b..804fa3d05 100644 --- a/src/Backend/CSharp/FromCore.hs +++ b/src/Backend/CSharp/FromCore.hs @@ -202,18 +202,18 @@ genTypeDef (Data info isExtend) genConstructor :: DataInfo -> DataRepr -> (ConInfo,ConRepr) -> Asm () genConstructor info dataRepr (con,conRepr) = case conRepr of - ConEnum _ _ _ + ConEnum{} -> return () - ConSingleton typeName _ _ + ConSingleton{conTypeName=typeName} -> assertion ("CSharp.FromCore.genTypeDef: singleton constructor with existentials?") (null (conInfoExists con)) $ conSingleton typeName - ConAsCons typeName _ nilName _ + ConAsCons typeName _ _ nilName _ -> -- merge it into the type class itself do ctx <- getModule putLn (vcat (map (ppConField ctx) (conInfoParams con) ++ ppConConstructor ctx con conRepr [])) - ConSingle typeName _ _ + ConSingle{conTypeName=typeName} -> -- merge it into the type class itself do ctx <- getModule let docs = map (ppConField ctx) (conInfoParams con) ++ ppConConstructor ctx con conRepr [] @@ -221,10 +221,10 @@ genConstructor info dataRepr (con,conRepr) = then return () else putLn (vcat docs) - ConStruct typeName _ _ + ConStruct{conTypeName=typeName} -> conStruct typeName - ConIso typeName _ _ + ConIso{conTypeName=typeName} -> conStruct typeName _ -> onTopLevel $ @@ -302,18 +302,18 @@ ppConConstructorEx ctx con conRepr conParams defaults then [] else [text "public" <+> (case conRepr of - ConAsCons typeName _ nilName _ -> ppDefName (typeClassName typeName) - ConSingle typeName _ _ -> ppDefName (typeClassName typeName) - ConStruct typeName _ _ -> ppDefName (typeClassName typeName) - ConIso typeName _ _ -> ppDefName (typeClassName typeName) - _ -> ppDefName (conClassName (conInfoName con))) <.> + ConAsCons typeName _ _ nilName _ -> ppDefName (typeClassName typeName) + ConSingle{conTypeName=typeName} -> ppDefName (typeClassName typeName) + ConStruct{conTypeName=typeName} -> ppDefName (typeClassName typeName) + ConIso {conTypeName=typeName} -> ppDefName (typeClassName typeName) + _ -> ppDefName (conClassName (conInfoName con))) <.> tupled (map ppParam (conInfoParams con)) <+> (case conRepr of - ConNormal typeName _ _ -> text ":" <+> text "base" <.> parens (ppTag ctx typeName (conInfoName con)) <.> space + ConNormal{conTypeName=typeName} -> text ":" <+> text "base" <.> parens (ppTag ctx typeName (conInfoName con)) <.> space _ -> empty) <.> block (linebreak <.> vcat ( (case conRepr of - ConStruct typeName _ _ -> [text "this." <.> ppTagName <+> text "=" <+> ppTag ctx typeName (conInfoName con) <.> semi] + ConStruct{conTypeName=typeName} -> [text "this." <.> ppTagName <+> text "=" <+> ppTag ctx typeName (conInfoName con) <.> semi] _ -> []) ++ map ppAssignConField conParams ++ map (ppAssignDefault ctx) defaults @@ -743,28 +743,28 @@ genCon tname repr targs args ctx <- getModule result $ hang 2 $ -- cast $ case repr of - ConEnum _ _ _ + ConEnum{} -> assertion "genCon: ConEnum has type args or args?" (null targs && null args) $ ppConEnum ctx tname - ConSingleton typeName _ _ + ConSingleton{conTypeName=typeName} -> ppConSingleton ctx typeName tname targs - ConStruct typeName _ _ | null args + ConStruct{conTypeName=typeName} | null args -> ppConSingleton ctx typeName tname targs - ConStruct typeName _ _ + ConStruct{conTypeName=typeName} -> text "new" <+> ppQName ctx (typeClassName typeName) <.> ppTypeArgs ctx targs tupled ({- ppTag ctx typeName (getName tname) : -} argDocs) - ConIso typeName _ _ + ConIso{conTypeName=typeName} -> text "new" <+> ppQName ctx (typeClassName typeName) <.> ppTypeArgs ctx targs tupled ({- ppTag ctx typeName (getName tname) : -} argDocs) _ -> text "new" <+> (case repr of - ConAsCons typeName _ _ _ + ConAsCons{conTypeName=typeName} -> ppQName ctx (typeClassName typeName) - ConSingle typeName _ _ + ConSingle{conTypeName=typeName} -> ppQName ctx (typeClassName typeName) _ -> ppQName ctx (conClassName (getName tname))) <.> (ppTypeArgs ctx targs) @@ -1056,10 +1056,10 @@ genTag (exprDoc,patterns) -- putLn (text "int" <+> ppDefName local <+> text "=" <+> exprDoc <.> text "." <.> ppTagName <.> semi) return (Just (exprDoc <.> text "." <.> ppTagName)) where - isConMatch (PatCon _ _ (ConNormal _ _ _) _ _ _ _ _) = True - isConMatch (PatCon _ _ (ConStruct _ _ _) _ _ _ _ _) = True - isConMatch (PatCon _ _ (ConIso _ _ _) _ _ _ _ _) = True - isConMatch _ = False + isConMatch (PatCon _ _ (ConNormal{}) _ _ _ _ _) = True + isConMatch (PatCon _ _ (ConStruct{}) _ _ _ _ _) = True + isConMatch (PatCon _ _ (ConIso{}) _ _ _ _ _) = True + isConMatch _ = False genBranch :: [Maybe Doc] -> [Doc] -> Bool -> Branch -> Asm () genBranch mbTagDocs exprDocs doTest branch@(Branch patterns [g@(Guard guard expr)]) -- TODO: adapt for multiple guards! @@ -1150,13 +1150,13 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) PatCon tname patterns repr targs exists tres info skip -- TODO: use skip -> do ctx <- getModule case repr of - ConEnum _ _ _ + ConEnum{} -> assertion "CSharp.FromCore.ppPatternTest.enum with patterns?" (null patterns) $ return [(test [exprDoc <+> text "==" <+> ppConEnum ctx tname],[],[],[])] - ConSingleton typeName _ _ + ConSingleton typeName _ _ _ -> assertion "CSharp.FromCore.ppPatternTest.singleton with patterns?" (null patterns) $ return [(test [exprDoc <+> text "==" <+> ppConSingleton ctx typeName tname tpars],[],[],[])] - ConSingle typeName _ _ + ConSingle typeName _ _ _ -> -- assertion ("CSharp.FromCore.ppPatternTest.single with test? ") (doTest == False) $ -- note: the assertion can happen when a nested singleton is tested do -- generate local for the test result @@ -1166,20 +1166,20 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) return [([] -- test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) targs] ,[],next,[])] - ConAsCons typeName _ nilName _ + ConAsCons typeName _ _ nilName _ -> do let next = genNextPatterns (exprDoc) (typeOf tname) patterns return [(test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) tpars] ,[],next,[])] - ConAsJust typeName _ _ _ + ConAsJust typeName _ _ _ _ -> testStruct typeName - ConStruct typeName _ _ + ConStruct typeName _ _ _ -> testStruct typeName - ConIso typeName _ _ + ConIso typeName _ _ _ -> testStruct typeName - ConNormal typeName _ _ + ConNormal typeName _ _ _ -> conTest ctx typeName exists -- TODO: use tags if available - ConOpen typeName _ + ConOpen{conTypeName=typeName} -> conTest ctx typeName exists where testStruct typeName diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index bfdb1a986..246f5addf 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -275,13 +275,13 @@ genTypeDef (Data info isExtend) -- special ConEnum{} -> constdecl <+> name <+> text "=" <+> int (conTag repr) <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) - ConSingleton _ _ _ | conInfoName c == nameOptionalNone + ConSingleton{} | conInfoName c == nameOptionalNone -> singletonValue "undefined" - ConSingleton _ DataStructAsMaybe _ + ConSingleton _ DataStructAsMaybe _ _ -> singletonValue "null" - ConSingleton _ DataAsMaybe _ + ConSingleton _ DataAsMaybe _ _ -> singletonValue "null" - ConSingleton _ DataAsList _ + ConSingleton _ DataAsList _ _ -> singletonValue "null" -- tagless ConIso{} -> genConstr penv c repr name args [] @@ -589,18 +589,18 @@ genMatch result scrutinees branches | otherwise -> case repr of -- special - ConEnum _ _ tag + ConEnum _ _ _ tag -> [debugWrap "genTest: enum" $ scrutinee <+> text "===" <+> int tag] - ConSingleton _ _ _ + ConSingleton{} | getName tn == nameOptionalNone -> [debugWrap "genTest: optional none" $ scrutinee <+> text "=== undefined"] - ConSingleton _ DataStructAsMaybe _ + ConSingleton _ DataStructAsMaybe _ _ -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsMaybe _ + ConSingleton _ DataAsMaybe _ _ -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsList _ + ConSingleton _ DataAsList _ _ -> [debugWrap "genTest: list like nil" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ _ tag + ConSingleton{conTag=tag} -> [debugWrap "genTest: singleton" $ scrutinee <.> dot <.> tagField <+> text "===" <+> int tag] ConSingle{} -- always succeeds, but need to test the fields -> concatMap diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 23d4966dd..b726afd2e 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -22,6 +22,7 @@ module Common.Syntax( Visibility(..) , dataDefIsRec, dataDefIsOpen, dataDefIsValue, dataDefSize , ValueRepr(..) , valueReprIsMixed, valueReprIsRaw, valueReprNew, valueReprZero + , valueReprRaw, valueReprSize, valueReprScan, valueReprSizeScan , HandlerSort(..) , isHandlerInstance, isHandlerNormal , OperationSort(..), readOperationSort @@ -216,7 +217,7 @@ dataDefIsValue ddef dataDefSize :: Platform -> DataDef -> Int dataDefSize platform ddef = case ddef of - DataDefValue v -> valueReprSize v + DataDefValue v -> valueReprSize platform v _ -> sizeField platform @@ -226,15 +227,21 @@ dataDefSize platform ddef data ValueRepr = ValueRepr{ valueReprRawSize :: !Int {- size in bytes -}, valueReprScanCount :: !Int {- count of scannable fields -}, - valueReprAlignment :: !Int {- minimal alignment -}, - valueReprSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} + valueReprAlignment :: !Int {- minimal alignment -} + -- valueReprSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} } - deriving Eq + deriving (Eq,Ord) instance Show ValueRepr where - show (ValueRepr raw scan align full) - = "{" ++ concat (intersperse "," (map show [raw,scan,align,full])) ++ "}" + show (ValueRepr raw scan align) + = "{" ++ concat (intersperse "," (map show [raw,scan,align])) ++ "}" + +valueReprSizeScan :: Platform -> ValueRepr -> (Int,Int) +valueReprSizeScan platform vrepr + = (valueReprSize platform vrepr, valueReprScanCount vrepr) +valueReprSize :: Platform -> ValueRepr -> Int +valueReprSize platform (ValueRepr raw scan align) = raw + (scan * sizeField platform) valueReprIsMixed :: ValueRepr -> Bool valueReprIsMixed v = (valueReprRawSize v > 0) && (valueReprScanCount v > 0) @@ -242,13 +249,18 @@ valueReprIsMixed v = (valueReprRawSize v > 0) && (valueReprScanCount v > 0) valueReprIsRaw :: ValueRepr -> Bool valueReprIsRaw v = (valueReprRawSize v > 0) && (valueReprScanCount v == 0) -valueReprNew :: Platform -> Int -> Int -> Int -> ValueRepr -valueReprNew platform rawSize scanCount align - = ValueRepr rawSize scanCount align (rawSize + (scanCount * sizeField platform)) +valueReprNew :: Int -> Int -> Int -> ValueRepr +valueReprNew rawSize scanCount align + = ValueRepr rawSize scanCount align -- (rawSize + (scanCount * sizeField platform)) valueReprZero :: ValueRepr -valueReprZero = ValueRepr 0 0 0 0 +valueReprZero = ValueRepr 0 0 0 + +valueReprRaw :: Int -> ValueRepr +valueReprRaw m = ValueRepr m 0 m +valueReprScan :: Int -> ValueRepr +valueReprScan n = ValueRepr 0 n 0 {-------------------------------------------------------------------------- Definition kind diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 8e3ababa4..6d4c5ddfb 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -67,6 +67,7 @@ module Core.Core ( -- Data structures , isConNormal , isConIso, isConAsJust , isDataStruct, isDataAsMaybe, isDataStructAsMaybe + , conReprAllocSize, conReprAllocSizeScan , getDataRepr, getDataReprEx, dataInfoIsValue , getConRepr , dataReprIsValue, conReprIsValue @@ -142,7 +143,7 @@ isExprFalse (Con tname _) = (getName tname == nameFalse) isExprFalse _ = False exprUnit :: Expr -exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum 0) +exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum valueReprZero 0) -- (ConInfo nameUnit typeUnit [] [] [] (TFun [] typeTotal typeUnit) Inductive rangeNull [] [] False Public "") (patFalse,exprFalse) = patExprBool nameFalse 0 @@ -150,9 +151,9 @@ exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum 0) patExprBool name tag = let tname = TName name typeBool - conEnum = ConEnum nameTpBool DataEnum tag + conEnum = ConEnum nameTpBool DataEnum valueReprZero tag conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False - [] (ValueRepr 1 0 1 1) Public "" + [] valueReprZero Public "" pat = PatCon tname [] conEnum [] [] typeBool conInfo False expr = Con tname conEnum in (pat,expr) @@ -176,10 +177,10 @@ makeList tp exprs = foldr cons nil exprs where nilTp = TForall [a] [] (TApp typeList [TVar a]) - nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList 0) + nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList valueReprZero 0) nil = TypeApp nilCon [tp] consTp = TForall [a] [] (typeFun [(nameNil,TVar a),(nameNil,TApp typeList [TVar a])] typeTotal (TApp typeList [TVar a])) - consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList nameNull 2) -- NOTE: depends on Cons being second in the definition in std/core :-( + consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull 2) -- NOTE: depends on Cons being second in the definition in std/core :-( cons expr xs = App (TypeApp consCon [tp]) [expr,xs] a = TypeVar (0) kindStar Bound @@ -363,21 +364,21 @@ data DataRepr = -- value types | DataOpen deriving (Eq,Ord,Show) -data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- part of enumeration (none has fields) - | ConIso{ conTypeName:: Name, conDataRepr :: DataRepr, conTag :: Int } -- one constructor with one field - | ConSingleton{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- constructor without fields (and not part of an enum) - | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) - | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) - | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- constructor as value type - | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conAsNil :: Name, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) - | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr } -- constructor of open data type - | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- a regular constructor +data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- part of enumeration (none has fields) + | ConIso{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- one constructor with one field + | ConSingleton{conTypeName::Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor without fields (and not part of an enum) + | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) + | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) + | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor as value type + | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) + | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr } -- constructor of open data type + | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- a regular constructor deriving (Eq,Ord,Show) -isConSingleton (ConSingleton _ _ _) = True +isConSingleton (ConSingleton{}) = True isConSingleton _ = False -isConNormal (ConNormal _ _ _) = True +isConNormal (ConNormal{}) = True isConNormal _ = False isConIso (ConIso{}) = True @@ -395,6 +396,16 @@ isDataStructAsMaybe _ = False isConAsJust (ConAsJust{}) = True isConAsJust _ = False +-- Return the allocation size (0 for value types) +conReprAllocSize :: Platform -> ConRepr -> Int +conReprAllocSize platform conRepr = fst (conReprAllocSizeScan platform conRepr) + +-- Return the allocation size (0 for value types) and scan count +conReprAllocSizeScan :: Platform -> ConRepr -> (Int,Int) +conReprAllocSizeScan platform conRepr + = let (size,scan) = valueReprSizeScan platform (conValRepr conRepr) + in if (conReprIsValue conRepr) then (0,scan) else (size,scan) + -- Value data is not heap allocated and needs no header dataReprIsValue :: DataRepr -> Bool dataReprIsValue drepr = (drepr <= DataStruct) @@ -432,25 +443,26 @@ getDataReprEx getIsValue info isValue = getIsValue info && not (dataInfoIsRec info) (dataRepr,conReprFuns) = if (dataInfoIsOpen(info)) - then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen) conInfos) + then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo)) conInfos) -- TODO: only for C#? check this during kind inference? -- else if (hasExistentials) -- then (DataNormal, map (\con -> ConNormal typeName) conInfos) else if (isValue && (null (dataInfoParams info) || typeName == nameTpCField) && all (\con -> null (conInfoParams con)) conInfos) - then (DataEnum,map (const (ConEnum typeName DataEnum)) conInfos) + then (DataEnum,map (\ci -> ConEnum typeName DataEnum (conInfoValueRepr ci)) conInfos) else if (length conInfos == 1) - then let conInfo = head conInfos + then let conInfo = head conInfos + valRepr = conInfoValueRepr conInfo dataRepr = if (isValue && length (conInfoParams conInfo) == 1) then DataIso else if (isValue && null singletons && not (dataInfoIsRec info)) then DataSingleStruct else DataSingle (not (null singletons)) in (dataRepr - ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr - else if length singletons == 1 then ConSingleton typeName dataRepr - else ConSingle typeName dataRepr]) + ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr valRepr + else if length singletons == 1 then ConSingleton typeName dataRepr valRepr + else ConSingle typeName dataRepr valRepr]) else if (isValue && not (dataInfoIsRec info)) then ( let dataRepr = if (length conInfos == 2 && length singletons == 1 && case (filter (\cinfo -> length (conInfoParams cinfo) == 1) conInfos) of -- at most 1 field @@ -458,8 +470,8 @@ getDataReprEx getIsValue info _ -> False) then DataStructAsMaybe else DataStruct - in (dataRepr, map (\con -> if null (conInfoParams con) then ConSingleton typeName dataRepr - else ConStruct typeName dataRepr) conInfos) + in (dataRepr, map (\ci -> if null (conInfoParams ci) then ConSingleton typeName dataRepr (conInfoValueRepr ci) + else ConStruct typeName dataRepr (conInfoValueRepr ci)) conInfos) ) else ( if (length conInfos == 2 && length singletons == 1) @@ -474,20 +486,20 @@ getDataReprEx getIsValue info in (if isMaybeLike then (DataAsMaybe - ,map (\con -> if (null (conInfoParams con)) then ConSingleton typeName DataAsMaybe - else ConAsJust typeName DataAsMaybe (conInfoName (head singletons))) conInfos) + ,map (\ci -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsMaybe (conInfoValueRepr ci) + else ConAsJust typeName DataAsMaybe (conInfoValueRepr ci) (conInfoName (head singletons))) conInfos) else (DataAsList - ,map (\con tag - -> if (null (conInfoParams con)) then ConSingleton typeName DataAsList tag - else ConAsCons typeName DataAsList (conInfoName (head singletons)) tag) conInfos) + ,map (\ci tag + -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsList (conInfoValueRepr ci) tag + else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) tag) conInfos) ) else let dataRepr = if (length singletons == length conInfos -1 || null conInfos) then DataSingleNormal else (DataNormal (not (null singletons))) in (dataRepr - ,map (\con -> if null (conInfoParams con) - then ConSingleton typeName dataRepr - else ConNormal typeName dataRepr) conInfos + ,map (\ci -> if null (conInfoParams ci) + then ConSingleton typeName dataRepr (conInfoValueRepr ci) + else ConNormal typeName dataRepr (conInfoValueRepr ci)) conInfos ) ) in (dataRepr, [conReprFun tag | (conReprFun,tag) <- zip conReprFuns [1..]]) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 0d4229fbf..75ff16122 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -303,9 +303,7 @@ parseValueRepr (scan,_) <- integer comma (align,_) <- integer - comma - (full,_) <- integer - return (ValueRepr (fromInteger raw) (fromInteger scan) (fromInteger align) (fromInteger full)) + return (ValueRepr (fromInteger raw) (fromInteger scan) (fromInteger align)) {-------------------------------------------------------------------------- diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 20bc1af99..7b5642163 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -864,7 +864,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? return DataDefNormal (DataDefAuto, DataDefValue vr) - -> if (valueReprSize vr <= 3*(sizeField platform) + -> if (valueReprSize platform vr <= 3*(sizeField platform) && hasKindStarResult (getKind typeResult) && (sort /= Retractive)) then -- trace ("default to value: " ++ show name ++ ": " ++ show (m,n)) $ @@ -875,11 +875,10 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef1 vis doc dataInfo <- case ddef1 of - DataDefValue (ValueRepr m n a _) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) + DataDefValue (ValueRepr m n a) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) -> -- add extra required tag field to the size -- todo: recalculate the constructor sizes as well! - do platform <- getPlatform - let ddef2 = DataDefValue (valueReprNew platform m (n+1) a) + do let ddef2 = DataDefValue (valueReprNew m (n+1) a) return $ dataInfo0{ dataInfoDef = ddef2 } _ -> return dataInfo0 @@ -894,11 +893,11 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort = do let ddefs = map conInfoValueRepr conInfos ddef <- maxDataDefs platform qname isVal nameDoc ddefs case ddef of - DataDefValue (ValueRepr 0 0 0 _) -- enumeration + DataDefValue (ValueRepr 0 0 0) -- enumeration -> let n = length conInfos - in if (n < 256) then return $ DataDefValue (ValueRepr 1 0 1 1) -- uint8_t - else if (n < 65536) then return $ DataDefValue (ValueRepr 2 0 2 2) -- uint16_t - else return $ DataDefValue (ValueRepr 4 0 4 4) -- uint32_t + in if (n < 256) then return $ DataDefValue (valueReprRaw 1) -- uint8_t + else if (n < 65536) then return $ DataDefValue (valueReprRaw 2) -- uint16_t + else return $ DataDefValue (valueReprRaw 4) -- uint32_t _ -> return ddef @@ -924,21 +923,21 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then do addWarning range (text "Type:" <+> nameDoc <+> text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform)) return (sizePtr platform) else return size - return (DataDefValue (valueReprNew platform m 0 m)) + return (DataDefValue (valueReprNew m 0 m)) maxDataDefs platform name isVal nameDoc [vr] -- singleton value = return (DataDefValue vr) maxDataDefs platform name isVal nameDoc (vr:vrs) = do dd <- maxDataDefs platform name isVal nameDoc vrs case (vr,dd) of - (ValueRepr 0 0 _ _, DataDefValue v) -> return (DataDefValue v) - (v, DataDefValue (ValueRepr 0 0 _ _)) -> return (DataDefValue v) - (ValueRepr m1 0 a1 _, DataDefValue (ValueRepr m2 0 a2 _)) - -> return (DataDefValue (valueReprNew platform (max m1 m2) 0 (max a1 a2))) - (ValueRepr 0 n1 a1 _, DataDefValue (ValueRepr 0 n2 a2 _)) - -> return (DataDefValue (valueReprNew platform 0 (max n1 n2) (max a1 a2))) - (ValueRepr m1 n1 a1 _, DataDefValue (ValueRepr m2 n2 a2 _)) + (ValueRepr 0 0 _, DataDefValue v) -> return (DataDefValue v) + (v, DataDefValue (ValueRepr 0 0 _)) -> return (DataDefValue v) + (ValueRepr m1 0 a1, DataDefValue (ValueRepr m2 0 a2)) + -> return (DataDefValue (valueReprNew (max m1 m2) 0 (max a1 a2))) + (ValueRepr 0 n1 a1, DataDefValue (ValueRepr 0 n2 a2)) + -> return (DataDefValue (valueReprNew 0 (max n1 n2) (max a1 a2))) + (ValueRepr m1 n1 a1, DataDefValue (ValueRepr m2 n2 a2)) -- equal scan fields - | n1 == n2 -> return (DataDefValue (valueReprNew platform (max m1 m2) n1 (max a1 a2))) + | n1 == n2 -> return (DataDefValue (valueReprNew (max m1 m2) n1 (max a1 a2))) -- non-equal scan fields | otherwise -> do if (isVal) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 7af14c914..52a5148af 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -65,14 +65,14 @@ orderConFields emitError getDataInfo platform isOpen fields restFields= [field | (field,_size,_scan,_align) <- rest] size = alignedSum preSize restSizes rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) - vrepr = valueReprNew platform rawSize scanCount alignment + vrepr = valueReprNew rawSize scanCount alignment -- trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ return (reverse rscan ++ restFields, vrepr) visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) = do mDataDef <- getDataDef getDataInfo tp case mDataDef of - Just (DataDefValue (ValueRepr raw scan align _)) + Just (DataDefValue (ValueRepr raw scan align)) -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors let alignment = max align alignment0 in if (raw > 0 && scan > 0) diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index 224ba65df..eb0bb4db2 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -674,7 +674,7 @@ inferExpr propagated expect (App assign@(Var name _ arng) [lhs@(_,lval),rhs@(_,r where errorAssignable = do contextError rng (getRange lval) (text "not an assignable expression") [(text "because",text "an assignable expression must be an application, index expression, or variable")] - return (typeUnit,typeTotal,Core.Con (Core.TName (nameTuple 0) typeUnit) (Core.ConEnum nameTpUnit Core.DataEnum 0)) + return (typeUnit,typeTotal,Core.Con (Core.TName (nameTuple 0) typeUnit) (Core.ConEnum nameTpUnit Core.DataEnum valueReprZero 0)) checkAssign = Check "an assignable identifier must have a reference type" diff --git a/src/Type/Type.hs b/src/Type/Type.hs index 70afacd55..2200c6776 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -78,7 +78,7 @@ import Common.NamePrim import Common.Range import Common.Id import Common.Failure -import Common.Syntax( Visibility, DataKind(..), DataDef(..), ValueRepr(..), dataDefIsRec, dataDefIsOpen, valueReprSize ) +import Common.Syntax( Visibility, DataKind(..), DataDef(..), ValueRepr(..), dataDefIsRec, dataDefIsOpen, valueReprSize, Platform ) import Kind.Kind {-------------------------------------------------------------------------- @@ -212,9 +212,10 @@ instance Show ConInfo where show info = show (conInfoName info) -conInfoSize :: ConInfo -> Int -conInfoSize conInfo - = valueReprSize (conInfoValueRepr conInfo) +-- return size and scan count for a constructor +conInfoSize :: Platform -> ConInfo -> Int +conInfoSize platform conInfo + = valueReprSize platform (conInfoValueRepr conInfo) -- | A type synonym is quantified by type parameters diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index c6600f479..0aacdeb92 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -2,7 +2,7 @@ module parc/parc22 import std/core/types = std/core/types = ""; import std/core = std/core = ""; pub rec type parc/parc22/hello { - pub con parc/parc22/World(i: int){0,1,8,8} : (i : int) -> parc/parc22/hello; + pub con parc/parc22/World(i: int){0,1,8} : (i : int) -> parc/parc22/hello; }; // Automatically generated. Retrieves the `i` constructor field of the `:hello` type. pub fun i : (^ hello : parc/parc22/hello) -> int From a4347e741db8284a0856a91b66265e76f9534c7c Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 20 Feb 2023 21:06:11 -0800 Subject: [PATCH 139/233] wip: working to make compression work again --- .../ide/vs2022/kklib-test-interactive.vcxproj | 2 +- .../kklib-test-interactive.vcxproj.filters | 2 +- kklib/include/kklib.h | 10 +++++---- kklib/include/kklib/integer.h | 6 +++-- kklib/include/kklib/platform.h | 22 +++++++++---------- src/Backend/C/FromCore.hs | 21 ++++++++++++------ src/Common/Name.hs | 13 ++++++++--- src/Kind/Infer.hs | 10 ++++----- src/Kind/Repr.hs | 14 ++++++------ test/cgen/data1.kk | 7 ++++++ 10 files changed, 65 insertions(+), 42 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index 72d3cb3d5..e96e841d9 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,7 +165,7 @@ - + diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index 799c30196..0b9ede722 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -8,7 +8,7 @@ - + diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 58f8a8667..0ff7e5f29 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 103 // modify on changes to trigger recompilation +#define KKLIB_BUILD 104 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -886,9 +886,11 @@ static inline bool kk_is_value(kk_intb_t i) { // If we assume `intptr_t` aligned pointers in the heap, we can use a larger heap when // using pointer compression (by shifting them by `KK_BOX_PTR_SHIFT`). #if !defined(KK_BOX_PTR_SHIFT) - #if (KK_INTB_SIZE <= 4) + #if (KK_INTB_SIZE <= 4 && KK_INTPTR_SHIFT >= 3) // shift by pointer alignment if we have at most 32-bit boxed ints - #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - KK_TAG_BITS) + // todo: unfortunately, bigint pointers must still have the lowest 2 bits as zero for + // fast ovf arithmetic. So we are conservative here + #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - 2) #else // don't bother with shifting if we have more than 32 bits available #define KK_BOX_PTR_SHIFT (0) @@ -953,7 +955,7 @@ static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { // Integer value encoding/decoding. May use smaller integers (`kk_intf_t`) // then boxed integers if `kk_intb_t` is larger than the natural register size. -#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - (KK_TAG_BITS + (extra))) +#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - (KK_TAG_BITS + (extra))) #define KK_INTF_BOX_MAX(extra) (KK_INTF_MAX >> (KK_TAG_BITS + (extra))) #define KK_INTF_BOX_MIN(extra) (-KK_INTF_BOX_MAX(extra) - 1) #define KK_UINTF_BOX_MAX(extra) (KK_UINTF_MAX >>(KK_TAG_BITS + (extra))) diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index fc5ef5b7b..7502291b5 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -464,7 +464,7 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: -----------------------------------------------------------------------------------*/ static kk_intf_t _kk_integer_value(kk_integer_t i) { - #if KK_INT_ARITHMETIC != KK_INT_USE_SOFA + #if KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF kk_assert_internal(kk_is_smallint(i)); #endif return (kk_intf_t)i.ibox; @@ -479,9 +479,11 @@ static kk_integer_t _kk_new_integer(kk_intf_t i) { #if (KK_INT_ARITHMETIC == KK_INT_USE_OVF) && (KK_TAG_VALUE==1) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_assert_internal((_kk_integer_value(x) & 2) == 0); + kk_assert_internal((_kk_integer_value(y) & 2) == 0); kk_intf_t z; if kk_unlikely(__builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z) || (z&2)==0) { - return kk_integer_add_generic(x,y,ctx); + return kk_integer_add_generic(x,y,ctx); } kk_assert_internal((z&3) == 2); return _kk_new_integer(z^3); diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index f9b01e86e..47d9a1ec6 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -177,9 +177,9 @@ #define kk_decl_noinline __attribute__((noinline)) #define kk_decl_align(a) __attribute__((aligned(a))) #define kk_decl_thread __thread -#define kk_struct_packed struct __attribute__((__packed__)) -#define kk_struct_packed_end -#define KK_HAS_STRUCT_PACKING 1 +//#define kk_struct_packed struct __attribute__((__packed__)) +//#define kk_struct_packed_end +//#define KK_HAS_STRUCT_PACKING 1 #elif defined(_MSC_VER) #pragma warning(disable:4214) // using bit field types other than int #pragma warning(disable:4101) // unreferenced local variable @@ -192,9 +192,9 @@ #define kk_decl_noinline __declspec(noinline) #define kk_decl_align(a) __declspec(align(a)) #define kk_decl_thread __declspec(thread) -#define kk_struct_packed __pragma(pack(push,1)) struct -#define kk_struct_packed_end __pragma(pack(pop)) -#define KK_HAS_STRUCT_PACKING 1 +//#define kk_struct_packed __pragma(pack(push,1)) struct +//#define kk_struct_packed_end __pragma(pack(pop)) +//#define KK_HAS_STRUCT_PACKING 1 #ifndef __cplusplus // need c++ compilation for correct atomic operations on msvc #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif @@ -204,10 +204,11 @@ #define kk_decl_noinline #define kk_decl_align(a) #define kk_decl_thread __thread +#endif + #define kk_struct_packed struct #define kk_struct_packed_end -#define KK_HAS_STRUCT_PACKING 0 -#endif + #if defined(__GNUC__) || defined(__clang__) #define kk_unlikely(x) (__builtin_expect(!!(x),false)) @@ -434,7 +435,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE KK_INTPTR_SIZE +#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) @@ -475,9 +476,6 @@ typedef uint32_t kk_uintb_t; #error "the given platform boxed integer size is (currently) not supported" #endif -#if KK_COMPRESS && !KK_HAS_STRUCT_PACKING -#error "pointer compression can only be used with C compilers that support struct packing" -#endif // A "field" integer is the largest natural integer that fits into a boxed value #if (KK_INTB_SIZE > KK_INTX_SIZE) // ensure it fits the natural register size diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 65a28a7b1..7b3821647 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -630,7 +630,7 @@ ppConTag con conRepr dataRepr genConstructorCreate :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> [(Name,Type)] -> Int -> Int -> Asm () -genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount +genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount = do {- if (null conFields && not (dataReprIsValue dataRepr)) then do let structTp = text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s" @@ -647,6 +647,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount -} when (dataRepr == DataOpen) $ emitToH $ text "extern kk_string_t" <+> conTagName con <.> semi let at = newHiddenName "at" + (paddingFields,conFields) = partition (isPaddingName . fst) allFields emitToH $ text "static inline" <+> ppName (typeClassName (dataInfoName info)) <+> conCreateNameInfo con <.> ntparameters ((if (dataReprIsValue dataRepr || (null conFields) || isDataAsMaybe dataRepr) then [] else [(at,typeReuse)]) @@ -669,10 +670,13 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount then [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi , tmp <.> text "._tag =" <+> ppConTag con conRepr dataRepr <.> semi] ++ map (assignField (\fld -> tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> fld)) conFields + ++ [tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" + | (padding,_) <- paddingFields] ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null();" | i <- [scanCount..(maxScanCount-1)]] else [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi {- <+> text "= {0}; // zero initializes all fields" -} ] ++ map (assignField (\fld -> tmp <.> text "." <.> fld)) conFields + ++ [tmp <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] ) ++ [text "return" <+> tmp <.> semi]) else {- if (null conFields) @@ -694,6 +698,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount <.> semi] ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> arguments [ppConTag con conRepr dataRepr] <.> semi ]) ++ map (assignField (\fld -> tmp <.> text "->" <.> fld)) conFields + ++ [tmp <.> text "->" <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] ++ {- [let base = text "&" <.> tmp <.> text "->_base" in if (dataReprMayHaveSingletons dataRepr) then text "return kk_datatype_from_base" <.> parens base <.> semi @@ -1176,13 +1181,14 @@ genLambda params eff body failure ("Backend.C.genLambda: " ++ msg) getDataInfo name = do newtypes <- getNewtypes return (newtypesLookupAny name newtypes) - (fields,vrepr) <- orderConFields emitError getDataInfo platform False freeVars - - let scanCount = valueReprScanCount vrepr - fieldDocs = [ppType tp <+> ppName name | (name,tp) <- fields] + (allFields,vrepr) <- orderConFields emitError getDataInfo platform 1 {- base.fun -} freeVars + + let (paddingFields,fields) = partition (isPaddingName . fst) allFields + scanCount = valueReprScanCount vrepr + -- fieldDocs = [ppType tp <+> ppName name | (name,tp) <- allFields] tpDecl = text "kk_struct_packed" <+> ppName funTpName <+> block ( vcat ([text "struct kk_function_s _base;"] ++ - [ppType tp <+> ppName name <.> semi | (name,tp) <- fields]) + [ppType tp <+> ppName name <.> semi | (name,tp) <- allFields]) ) <.> semi <-> text "kk_struct_packed_end" funSig = text (if toH then "extern" else "static") <+> ppType (typeOf body) @@ -1197,10 +1203,11 @@ genLambda params eff body --text "static" <+> structDoc <+> text "_self =" -- <+> braces (braces (text "static_header(1, TAG_FUNCTION), box_cptr(&" <.> ppName funName <.> text ")")) <.> semi ,text "return kk_function_dup(_fself,kk_context());"] - else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty (scanCount + 1) -- +1 for the _base.fun + else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty scanCount ] <.> semi ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] + ++ [text "_self->" <.> ppName paddingName <+> text "= kk_box_null();" | (paddingName,_) <- paddingFields] ++ [text "return kk_datatype_from_base(&_self->_base, kk_context());"]) ) diff --git a/src/Common/Name.hs b/src/Common/Name.hs index db78754d2..5ff2eafca 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -24,6 +24,7 @@ module Common.Name , qualify, unqualify, isQualified, qualifier , nameId, nameModule + , newPaddingName, isPaddingName , newFieldName, isFieldName, isWildcard , newHiddenExternalName, isHiddenExternalName , newHiddenName, isHiddenName, hiddenNameStartsWith @@ -302,7 +303,7 @@ makeFreshHiddenName s name range where idFromPos pos = "-l" ++ show (posLine pos) ++ "-c" ++ show (posColumn pos) hiddenNameStartsWith name pre - = nameId name `startsWith` ("." ++ pre ++ "-") + = nameId name `startsWith` ("." ++ pre) toUniqueName :: Int -> Name -> Name toUniqueName i name @@ -322,18 +323,24 @@ toHiddenUniqueName i s name xname = if (isAlpha c || c=='.' ) then name else newQualified (nameModule name) ("op") +newPaddingName i + = newHiddenName ("padding" ++ show i) + +isPaddingName name + = hiddenNameStartsWith name "padding" + newFieldName i = newHiddenName ("field" ++ show i) isFieldName name - = isHiddenName name + = hiddenNameStartsWith name "field" newImplicitTypeVarName i = newHiddenName ("t" ++ show i) -isImplicitTypeVarName name +isImplicitTypeVarName name = isHiddenName name diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 7b5642163..0658a4325 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -867,10 +867,10 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort -> if (valueReprSize platform vr <= 3*(sizeField platform) && hasKindStarResult (getKind typeResult) && (sort /= Retractive)) - then -- trace ("default to value: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefValue vr) - else -- trace ("default to reference: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefNormal) + then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ + return (DataDefValue vr) + else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ + return (DataDefNormal) _ -> return DataDefNormal let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef1 vis doc @@ -1020,7 +1020,7 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id let nameDoc = color (colorCons cs) (pretty name) addError rng (makeMsg nameDoc) platform <- getPlatform - (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform isOpen fields + (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform (if isOpen then 1 else 0) fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars fields diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 52a5148af..bddfb597e 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -27,9 +27,9 @@ import Type.Type -- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) -- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes orderConFields :: Monad m => ((Doc -> Doc) -> m ()) -> (Name -> m (Maybe DataInfo)) -> Platform - -> Bool -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) -orderConFields emitError getDataInfo platform isOpen fields - = do visit ([], [], [], if isOpen then 1 else 0, 0) fields + -> Int -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) +orderConFields emitError getDataInfo platform extraPreScan fields + = do visit ([], [], [], extraPreScan, 0) fields where -- visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) visit (rraw, rmixed, rscan, scanCount0, alignment0) [] @@ -50,10 +50,10 @@ orderConFields emitError getDataInfo platform isOpen fields (padding,mixedScan) = case rmixed of ((_,_,scan,ralign):_) - -> let padSize = preSize `mod` ralign + -> let padSize = (preSize + (scan * sizeField platform)) `mod` ralign padCount = padSize `div` sizeField platform in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ - ([((newHiddenName ("padding" ++ show i),typeInt),sizeField platform,1,sizeField platform) | i <- [1..padCount]] + ([((newPaddingName (scanCount0 + i),typeAny),sizeField platform,1,sizeField platform) | i <- [1..padCount]] ,scan + padCount) [] -> ([],0) @@ -63,10 +63,10 @@ orderConFields emitError getDataInfo platform isOpen fields rest = padding ++ rmixed ++ reverse rraw restSizes = [size | (_field,size,_scan,_align) <- rest] restFields= [field | (field,_size,_scan,_align) <- rest] - size = alignedSum preSize restSizes + size = alignedSum preSize restSizes rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) vrepr = valueReprNew rawSize scanCount alignment - -- trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ + -- (if null padding then id else trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ return (reverse rscan ++ restFields, vrepr) visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index dadd20772..758971704 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -63,3 +63,10 @@ type mix { Mix( p:point, m : mix, i : int32, c : char ); MixNil } // ensure the tag of maybe is in the scanned fields (3+1) type scantag { ScanTag( i : int, z : char, m : maybe, p : point ) } + + +// test padding between field and raw +value struct intdouble( i : int, d : float64 ) + +// test explicit padding between fields and mixed intdouble +struct padding( x : int, y : int, id : intdouble ) \ No newline at end of file From 2200b17ff105184d4e415b774393d3520572fc4e Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 21 Feb 2023 09:59:34 -0800 Subject: [PATCH 140/233] various fixes to make compressed mode work again --- kklib/include/kklib.h | 13 +++++++++---- kklib/include/kklib/platform.h | 2 +- kklib/src/all.c | 16 +++++++++++----- src/Common/Name.hs | 7 ++++--- src/Kind/Infer.hs | 20 +++++++------------- src/Kind/Repr.hs | 2 +- 6 files changed, 33 insertions(+), 27 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 0ff7e5f29..7804e750a 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 104 // modify on changes to trigger recompilation +#define KKLIB_BUILD 105 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -332,7 +332,11 @@ static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { --------------------------------------------------------------------------------------*/ #ifdef KK_MIMALLOC #if !defined(MI_MAX_ALIGN_SIZE) - #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #if (KK_MIMALLOC > 1) + #define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #else + #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #endif #endif #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) #define MI_DEBUG 3 @@ -888,8 +892,9 @@ static inline bool kk_is_value(kk_intb_t i) { #if !defined(KK_BOX_PTR_SHIFT) #if (KK_INTB_SIZE <= 4 && KK_INTPTR_SHIFT >= 3) // shift by pointer alignment if we have at most 32-bit boxed ints - // todo: unfortunately, bigint pointers must still have the lowest 2 bits as zero for - // fast ovf arithmetic. So we are conservative here + // note: unfortunately, bigint pointers must still have the lowest 2 bits as zero for + // fast ovf arithmetic. So we are conservative here. If we always use SOFA or TAGOVF + // in the compressed case, we could shift by one more bit and double the heap space. #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - 2) #else // don't bother with shifting if we have more than 32 bits available diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 47d9a1ec6..79d5b1997 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -435,7 +435,7 @@ typedef unsigned kk_uintx_t; // a boxed value is by default the size of an `intptr_t`. #if !defined(KK_INTB_SIZE) -#define KK_INTB_SIZE 4 // KK_INTPTR_SIZE +#define KK_INTB_SIZE KK_INTPTR_SIZE #endif #define KK_INTB_BITS (8*KK_INTB_SIZE) diff --git a/kklib/src/all.c b/kklib/src/all.c index 1dadb4132..6f0846cf7 100644 --- a/kklib/src/all.c +++ b/kklib/src/all.c @@ -9,13 +9,19 @@ #define _DEFAULT_SOURCE #define __USE_MINGW_ANSI_STDIO // so %z is valid on mingw - #if defined(KK_MIMALLOC) -#if !defined(MI_MAX_ALIGN_SIZE) && (KK_MIMALLOC > 1) -#define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #if !defined(MI_MAX_ALIGN_SIZE) + #if (KK_MIMALLOC > 1) + #define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #else + #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #endif + #endif + #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) + #define MI_DEBUG 3 + #endif + #include "../mimalloc/src/static.c" // must come first on freeBSD #endif -#include "../mimalloc/src/static.c" // must come first on freeBSD -#endif #include diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 5ff2eafca..1f8ba4702 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -303,7 +303,7 @@ makeFreshHiddenName s name range where idFromPos pos = "-l" ++ show (posLine pos) ++ "-c" ++ show (posColumn pos) hiddenNameStartsWith name pre - = nameId name `startsWith` ("." ++ pre) + = nameId name `startsWith` ("." ++ pre ++ "-") toUniqueName :: Int -> Name -> Name toUniqueName i name @@ -327,14 +327,15 @@ newPaddingName i = newHiddenName ("padding" ++ show i) isPaddingName name - = hiddenNameStartsWith name "padding" + = -- hiddenNameStartsWith name "padding" + nameId name `startsWith` (".padding") newFieldName i = newHiddenName ("field" ++ show i) isFieldName name - = hiddenNameStartsWith name "field" + = isHiddenName name -- hiddenNameStartsWith name "field" newImplicitTypeVarName i diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 0658a4325..6d17b24f7 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -816,25 +816,18 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort consinfos <- mapM (resolveConstructor (getName newtp') sort (dataDefIsOpen ddef) (not (dataDefIsOpen ddef) && length constructors == 1) typeResult typeVars tvarMap) constructors - let (constructors',infos) = unzip consinfos + let (constructors',conInfos) = unzip consinfos --check recursion if (sort == Retractive) then return () else let effNames = concatMap fromOpsName recNames fromOpsName nm = if (isOperationsName nm) then [fromOperationsName nm] else [] - in if (any (occursNegativeCon (recNames ++ effNames)) (infos)) + in if (any (occursNegativeCon (recNames ++ effNames)) (conInfos)) then do addError range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> text " hint: declare it as a 'type rec' (or 'effect rec)' to allow negative occurrences") else return () - {- - -- is a maybe like reference type? - let isAsMaybe = not isRec && case sortOn (length . conInfoParams) infos of - [nothing,just] -> length (conInfoParams nothing) == 0 && case conInfoParams just of - [(_,TVar _)] -> True - _ -> False - _ -> False - -} + -- value types ddef1 <- case ddef of DataDefNormal @@ -853,7 +846,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort _ -- Value or auto, and not recursive -> -- determine the raw fields and total size do platform <- getPlatform - dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc infos + dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc conInfos case (ddef,dd) of -- note: m = raw, n = scan (DataDefValue _, DataDefValue vr) -> if (hasKindStarResult (getKind typeResult)) @@ -864,7 +857,8 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? return DataDefNormal (DataDefAuto, DataDefValue vr) - -> if (valueReprSize platform vr <= 3*(sizeField platform) + -> if (valueReprSize platform vr <= 3*(sizePtr platform) -- not too large in bytes + && maximum (map (length . conInfoParams) conInfos) <= 3 -- and at most 3 members && hasKindStarResult (getKind typeResult) && (sort /= Retractive)) then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ @@ -873,7 +867,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort return (DataDefNormal) _ -> return DataDefNormal - let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef1 vis doc + let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos range ddef1 vis doc dataInfo <- case ddef1 of DataDefValue (ValueRepr m n a) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) -> -- add extra required tag field to the size diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index bddfb597e..ff55011b9 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -50,7 +50,7 @@ orderConFields emitError getDataInfo platform extraPreScan fields (padding,mixedScan) = case rmixed of ((_,_,scan,ralign):_) - -> let padSize = (preSize + (scan * sizeField platform)) `mod` ralign + -> let padSize = preSize `mod` ralign padCount = padSize `div` sizeField platform in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ ([((newPaddingName (scanCount0 + i),typeAny),sizeField platform,1,sizeField platform) | i <- [1..padCount]] From 197328c2f6d2546eabfe976f1e09e9b02938a9a7 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Tue, 21 Feb 2023 14:36:17 -0800 Subject: [PATCH 141/233] remove struct packing --- kklib/include/kklib.h | 2 +- kklib/include/kklib/platform.h | 9 --------- lib/std/core/types.kk | 4 ++-- src/Backend/C/FromCore.hs | 12 ++++++------ 4 files changed, 9 insertions(+), 18 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 7804e750a..39d4fc9bf 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 105 // modify on changes to trigger recompilation +#define KKLIB_BUILD 106 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 79d5b1997..9887247c1 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -177,9 +177,6 @@ #define kk_decl_noinline __attribute__((noinline)) #define kk_decl_align(a) __attribute__((aligned(a))) #define kk_decl_thread __thread -//#define kk_struct_packed struct __attribute__((__packed__)) -//#define kk_struct_packed_end -//#define KK_HAS_STRUCT_PACKING 1 #elif defined(_MSC_VER) #pragma warning(disable:4214) // using bit field types other than int #pragma warning(disable:4101) // unreferenced local variable @@ -192,9 +189,6 @@ #define kk_decl_noinline __declspec(noinline) #define kk_decl_align(a) __declspec(align(a)) #define kk_decl_thread __declspec(thread) -//#define kk_struct_packed __pragma(pack(push,1)) struct -//#define kk_struct_packed_end __pragma(pack(pop)) -//#define KK_HAS_STRUCT_PACKING 1 #ifndef __cplusplus // need c++ compilation for correct atomic operations on msvc #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif @@ -206,9 +200,6 @@ #define kk_decl_thread __thread #endif -#define kk_struct_packed struct -#define kk_struct_packed_end - #if defined(__GNUC__) || defined(__clang__) #define kk_unlikely(x) (__builtin_expect(!!(x),false)) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 0cd27fa06..fd0245f86 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -9,7 +9,7 @@ /* Core types. This module is implicitly imported and all functions and types - are always available. + are always available. These types are required to be defined for the compiler to work correctly (i.e. types like `:int` or `:div`) */ @@ -18,7 +18,7 @@ module std/core/types pub infixr 30 (&&) pub infixr 20 (||) -// build: 102 +// build: 105 // ---------------------------------------------------------------------------- // Core types diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 7b3821647..897069529 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -505,14 +505,14 @@ genTypeDefPost (Data info isExtend) else if (dataRepr == DataEnum || not (dataReprIsValue dataRepr)) then return () else emitToH $ if (needsTagField dataRepr) - then ppVis (dataInfoVis info) <.> text "kk_struct_packed" <+> ppName name <.> text "_s" + then ppVis (dataInfoVis info) <.> text "struct" <+> ppName name <.> text "_s" <+> block (text "kk_value_tag_t _tag;" <-> text "union" <+> block (vcat ( map ppStructConField (dataInfoConstrs info) ++ (if (maxScanCount > 0 && minScanCount /= maxScanCount) then [text "kk_box_t _fields[" <.> pretty maxScanCount <.> text "];"] else []) - )) <+> text "_cons;") <.> semi <-> text "kk_struct_packed_end" + )) <+> text "_cons;") <.> semi -- <-> text "kk_struct_packed_end" <-> ppVis (dataInfoVis info) <.> text "typedef struct" <+> ppName name <.> text "_s" <+> ppName (typeClassName name) <.> semi else ppVis (dataInfoVis info) <.> text "typedef struct" <+> (case (dataRepr,dataInfoConstrs info) of @@ -552,10 +552,10 @@ genConstructorType info dataRepr (con,conRepr,conFields,scanCount) = -> return () -- represented as an enum -- _ | null conFields && (dataRepr < DataNormal && not (isDataStructLike dataRepr)) -- -> return () - _ -> do emitToH $ ppVis (conInfoVis con) <.> text "kk_struct_packed" <+> ppName ((conInfoName con)) <+> + _ -> do emitToH $ ppVis (conInfoVis con) <.> text "struct" <+> ppName ((conInfoName con)) <+> block (let fields = (typeField ++ map ppConField conFields) in if (null fields) then text "kk_box_t _unused;" -- avoid empty struct - else vcat fields) <.> semi <-> text "kk_struct_packed_end" + else vcat fields) <.> semi -- <-> text "kk_struct_packed_end" where typeField = if (dataReprIsValue dataRepr) then [] else [text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s" <+> text "_base;"] @@ -1186,10 +1186,10 @@ genLambda params eff body let (paddingFields,fields) = partition (isPaddingName . fst) allFields scanCount = valueReprScanCount vrepr -- fieldDocs = [ppType tp <+> ppName name | (name,tp) <- allFields] - tpDecl = text "kk_struct_packed" <+> ppName funTpName <+> block ( + tpDecl = text "struct" <+> ppName funTpName <+> block ( vcat ([text "struct kk_function_s _base;"] ++ [ppType tp <+> ppName name <.> semi | (name,tp) <- allFields]) - ) <.> semi <-> text "kk_struct_packed_end" + ) <.> semi -- <-> text "kk_struct_packed_end" funSig = text (if toH then "extern" else "static") <+> ppType (typeOf body) <+> ppName funName <.> parameters ([text "kk_function_t _fself"] ++ From 5a3b8f1e6d7120efd309bd422d8fccad771b2bba Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Wed, 22 Feb 2023 17:44:52 -0800 Subject: [PATCH 142/233] refactor datadef calculation --- src/Backend/C/FromCore.hs | 8 +-- src/Kind/Infer.hs | 128 ++++++---------------------------- src/Kind/Repr.hs | 140 +++++++++++++++++++++++++++++++++++--- 3 files changed, 152 insertions(+), 124 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 897069529..09808e2dc 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1175,13 +1175,13 @@ genLambda params eff body freeVars = [(nm,tp) | (TName nm tp) <- tnamesList (freeLocals (Lam params eff body))] platform <- getPlatform - let emitError makeMsg = do env <- getEnv - let lam = text (show (cdefName env) ++ ":") - let msg = show (makeMsg lam) + env <- getEnv + let emitError doc = do let msg = show doc failure ("Backend.C.genLambda: " ++ msg) + nameDoc = text (show (cdefName env) ++ ".") getDataInfo name = do newtypes <- getNewtypes return (newtypesLookupAny name newtypes) - (allFields,vrepr) <- orderConFields emitError getDataInfo platform 1 {- base.fun -} freeVars + (allFields,vrepr) <- orderConFields emitError nameDoc getDataInfo platform 1 {- base.fun -} freeVars let (paddingFields,fields) = partition (isPaddingName . fst) allFields scanCount = valueReprScanCount vrepr diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 6d17b24f7..b5c5427fc 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -51,7 +51,7 @@ import Kind.Assumption import Kind.Constructors import Kind.Newtypes import Kind.Synonym -import Kind.Repr( orderConFields ) +import Kind.Repr( createDataDef ) import Type.Type import Type.Assumption import Type.TypeVar( tvsIsEmpty, ftv, subNew, (|->), tvsMember, tvsList ) @@ -814,58 +814,27 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort nameDoc = color (colorType cs) (pretty name) consinfos <- mapM (resolveConstructor (getName newtp') sort - (dataDefIsOpen ddef) (not (dataDefIsOpen ddef) && length constructors == 1) + (not (dataDefIsOpen ddef) && length constructors == 1) typeResult typeVars tvarMap) constructors - let (constructors',conInfos) = unzip consinfos + let (constructors',conInfos0) = unzip consinfos --check recursion if (sort == Retractive) then return () else let effNames = concatMap fromOpsName recNames fromOpsName nm = if (isOperationsName nm) then [fromOperationsName nm] else [] - in if (any (occursNegativeCon (recNames ++ effNames)) (conInfos)) + in if (any (occursNegativeCon (recNames ++ effNames)) (conInfos0)) then do addError range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> text " hint: declare it as a 'type rec' (or 'effect rec)' to allow negative occurrences") else return () - -- value types - ddef1 <- case ddef of - DataDefNormal - -> return (if (isRec) then DataDefRec else DataDefNormal) - DataDefValue{} | isRec - -> do addError range (text "Type" <+> nameDoc <+> text "cannot be declared as a value type since it is recursive.") - return ddef - DataDefAuto | isRec - -> return DataDefRec - -- DataDefAuto | isAsMaybe - -- -> return DataDefNormal - DataDefOpen - -> return DataDefOpen - DataDefRec - -> return DataDefRec - _ -- Value or auto, and not recursive - -> -- determine the raw fields and total size - do platform <- getPlatform - dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc conInfos - case (ddef,dd) of -- note: m = raw, n = scan - (DataDefValue _, DataDefValue vr) - -> if (hasKindStarResult (getKind typeResult)) - then return (DataDefValue vr) - else do addError range (text "Type" <+> nameDoc <+> text "is declared as a value type but does not have a value kind ('V').") -- should never happen? - return DataDefNormal - (DataDefValue _, DataDefNormal) - -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? - return DataDefNormal - (DataDefAuto, DataDefValue vr) - -> if (valueReprSize platform vr <= 3*(sizePtr platform) -- not too large in bytes - && maximum (map (length . conInfoParams) conInfos) <= 3 -- and at most 3 members - && hasKindStarResult (getKind typeResult) - && (sort /= Retractive)) - then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ - return (DataDefValue vr) - else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ - return (DataDefNormal) - _ -> return DataDefNormal + let emitError d = addError range (text "Type" <+> nameDoc <+> d) + emitWarning d = addWarning range (text "Type" <+> nameDoc <+> d) + platform <- getPlatform + (ddef1,conInfos) + <- createDataDef emitError emitWarning lookupDataInfo + platform qname (hasKindStarResult (getKind typeResult)) isRec sort + (if dataDefIsOpen ddef then 1 else 0) ddef conInfos0 let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos range ddef1 vis doc dataInfo <- case ddef1 of @@ -882,66 +851,6 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort where conVis (UserCon name exist params result rngName rng vis _) = vis - toDefValues :: Platform -> Bool -> Name -> Doc -> [ConInfo] -> KInfer DataDef - toDefValues platform isVal qname nameDoc conInfos - = do let ddefs = map conInfoValueRepr conInfos - ddef <- maxDataDefs platform qname isVal nameDoc ddefs - case ddef of - DataDefValue (ValueRepr 0 0 0) -- enumeration - -> let n = length conInfos - in if (n < 256) then return $ DataDefValue (valueReprRaw 1) -- uint8_t - else if (n < 65536) then return $ DataDefValue (valueReprRaw 2) -- uint16_t - else return $ DataDefValue (valueReprRaw 4) -- uint32_t - _ -> return ddef - - - -- note: (m = raw, n = scan) - maxDataDefs :: Platform -> Name -> Bool -> Doc -> [ValueRepr] -> KInfer DataDef - maxDataDefs platform name False nameDoc [] -- reference type, no constructors - = return DataDefNormal - maxDataDefs platform name True nameDoc [] -- primitive abstract value type with no constructors - = do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) - then 4 - else if (name == nameTpFloat || name == nameTpInt64) - then 8 - else if (name == nameTpInt8) - then 1 - else if (name == nameTpInt16 || name == nameTpFloat16) - then 2 - else if (name == nameTpAny || name == nameTpCField || name == nameTpIntPtrT) - then (sizePtr platform) - else if (name==nameTpSSizeT) - then (sizeSize platform) - else 0 - m <- if (size <= 0) - then do addWarning range (text "Type:" <+> nameDoc <+> text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform)) - return (sizePtr platform) - else return size - return (DataDefValue (valueReprNew m 0 m)) - maxDataDefs platform name isVal nameDoc [vr] -- singleton value - = return (DataDefValue vr) - maxDataDefs platform name isVal nameDoc (vr:vrs) - = do dd <- maxDataDefs platform name isVal nameDoc vrs - case (vr,dd) of - (ValueRepr 0 0 _, DataDefValue v) -> return (DataDefValue v) - (v, DataDefValue (ValueRepr 0 0 _)) -> return (DataDefValue v) - (ValueRepr m1 0 a1, DataDefValue (ValueRepr m2 0 a2)) - -> return (DataDefValue (valueReprNew (max m1 m2) 0 (max a1 a2))) - (ValueRepr 0 n1 a1, DataDefValue (ValueRepr 0 n2 a2)) - -> return (DataDefValue (valueReprNew 0 (max n1 n2) (max a1 a2))) - (ValueRepr m1 n1 a1, DataDefValue (ValueRepr m2 n2 a2)) - -- equal scan fields - | n1 == n2 -> return (DataDefValue (valueReprNew (max m1 m2) n1 (max a1 a2))) - -- non-equal scan fields - | otherwise -> - do if (isVal) - then addError range (text "type:" <+> nameDoc <+> text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> - text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") - else addWarning range (text "type:" <+> nameDoc <+> text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") - -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ - return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) - _ -> return DataDefNormal - occursNegativeCon :: [Name] -> ConInfo -> Bool occursNegativeCon names conInfo = let (_,_,rho) = splitPredType (conInfoType conInfo) @@ -995,8 +904,8 @@ resolveKind infkind resolve (KICon kind) = kind resolve (KIApp k1 k2) = KApp (resolve k1) (resolve k2) -resolveConstructor :: Name -> DataKind -> Bool -> Bool -> Type -> [TypeVar] -> M.NameMap TypeVar -> UserCon (KUserType InfKind) UserType InfKind -> KInfer (UserCon Type Type Kind, ConInfo) -resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams idmap (UserCon name exist params mbResult rngName rng vis doc) +resolveConstructor :: Name -> DataKind -> Bool -> Type -> [TypeVar] -> M.NameMap TypeVar -> UserCon (KUserType InfKind) UserType InfKind -> KInfer (UserCon Type Type Kind, ConInfo) +resolveConstructor typeName typeSort isSingleton typeResult typeParams idmap (UserCon name exist params mbResult rngName rng vis doc) = do qname <- qualifyDef name exist' <- mapM resolveTypeBinder exist existVars <- mapM (\ename -> freshTypeVar ename Bound) exist' @@ -1010,11 +919,11 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id addRangeInfo rng (Decl "con" qname (mangleConName qname)) addRangeInfo rngName (Id qname (NICon scheme) True) let fields = map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params')) - emitError makeMsg = do cs <- getColorScheme - let nameDoc = color (colorCons cs) (pretty name) - addError rng (makeMsg nameDoc) + -- emitError makeMsg = do cs <- getColorScheme + -- let nameDoc = color (colorCons cs) (pretty name) + -- addError rng (makeMsg nameDoc) platform <- getPlatform - (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform (if isOpen then 1 else 0) fields + -- (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform (if isOpen then 1 else 0) fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars fields @@ -1023,7 +932,8 @@ resolveConstructor typeName typeSort isOpen isSingleton typeResult typeParams id (map (binderNameRange . snd) params') (map fst params') isSingleton - orderedFields vrepr + -- orderedFields vrepr + [] valueReprZero -- initialized later at the datadef vis doc) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index ff55011b9..71daa5bb6 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -9,7 +9,7 @@ -} ----------------------------------------------------------------------------- -module Kind.Repr( orderConFields ) where +module Kind.Repr( orderConFields, createDataDef ) where import Control.Monad( when ) import Lib.PPrint @@ -19,6 +19,130 @@ import Common.Syntax import Common.Failure import Type.Type +--------------------------------------------------------- +-- Create a datadef and elaborate conInfo's with a ValueRepr +-- and correctly ordered fields depending on alignment +-- constraints and platform sizes. +--------------------------------------------------------- + +-- value types +createDataDef :: Monad m => (Doc-> m ()) -> (Doc-> m ()) -> (Name -> m (Maybe DataInfo)) + -> Platform -> Name -> Bool -> Bool -> DataKind + -> Int -> DataDef -> [ConInfo] -> m (DataDef,[ConInfo]) +createDataDef emitError emitWarning lookupDataInfo + platform name resultHasKindStar isRec sort + extraFields defaultDef conInfos0 + = do --calculate the value repr of each constructor + conInfos <- mapM createConInfoRepr conInfos0 + -- datadef + ddef <- case defaultDef of + DataDefNormal + -> return (if (isRec) then DataDefRec else DataDefNormal) + DataDefValue{} | isRec + -> do emitError $ text "cannot be declared as a value type since it is recursive." + return defaultDef + DataDefAuto | isRec + -> return DataDefRec + -- DataDefAuto | isAsMaybe + -- -> return DataDefNormal + DataDefOpen + -> return DataDefOpen + DataDefRec + -> return DataDefRec + _ -- Value or auto, and not recursive + -> -- determine the raw fields and total size + do dd <- createMaxDataDef conInfos + case (defaultDef,dd) of -- note: m = raw, n = scan + (DataDefValue _, DataDefValue vr) + -> if resultHasKindStar + then return (DataDefValue vr) + else do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? + return DataDefNormal + (DataDefValue _, DataDefNormal) + -> do emitError $ text "cannot be used as a value type." -- should never happen? + return DataDefNormal + (DataDefAuto, DataDefValue vr) + -> if (valueReprSize platform vr <= 3*(sizePtr platform) -- not too large in bytes + && maximum (map (length . conInfoParams) conInfos) <= 3 -- and at most 3 members + && resultHasKindStar + && (sort /= Retractive)) + then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ + return (DataDefValue vr) + else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ + return (DataDefNormal) + _ -> return DataDefNormal + return (ddef,conInfos) + where + isVal :: Bool + isVal = dataDefIsValue defaultDef + + -- createConInfoRepr :: ConInfo -> m ConInfo + createConInfoRepr conInfo + = do (orderedFields,vrepr) <- orderConFields emitError (text "constructor" <+> pretty (conInfoName conInfo)) + lookupDataInfo platform extraFields (conInfoParams conInfo) + return (conInfo{ conInfoOrderedParams = orderedFields, conInfoValueRepr = vrepr } ) + + -- createMaxDataDef :: [ConInfo] -> m DataDef + createMaxDataDef conInfos + = do let vreprs = map conInfoValueRepr conInfos + ddef <- maxDataDefs vreprs + case ddef of + DataDefValue (ValueRepr 0 0 0) -- enumeration + -> let n = length conInfos + in if (n < 256) then return $ DataDefValue (valueReprRaw 1) -- uint8_t + else if (n < 65536) then return $ DataDefValue (valueReprRaw 2) -- uint16_t + else return $ DataDefValue (valueReprRaw 4) -- uint32_t + _ -> return ddef + + + -- note: (m = raw, n = scan) + -- maxDataDefs :: Monad m => [ValueRepr] -> m DataDef + maxDataDefs [] + = if not isVal + then return DataDefNormal -- reference type, no constructors + else do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) + then 4 + else if (name == nameTpFloat || name == nameTpInt64) + then 8 + else if (name == nameTpInt8) + then 1 + else if (name == nameTpInt16 || name == nameTpFloat16) + then 2 + else if (name == nameTpAny || name == nameTpCField || name == nameTpIntPtrT) + then (sizePtr platform) + else if (name==nameTpSSizeT) + then (sizeSize platform) + else 0 + m <- if (size <= 0) + then do emitWarning $ text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform) + return (sizePtr platform) + else return size + return (DataDefValue (valueReprNew m 0 m)) + maxDataDefs [vr] -- singleton value + = return (DataDefValue vr) + maxDataDefs (vr:vrs) + = do dd <- maxDataDefs vrs + case (vr,dd) of + (ValueRepr 0 0 _, DataDefValue v) -> return (DataDefValue v) + (v, DataDefValue (ValueRepr 0 0 _)) -> return (DataDefValue v) + (ValueRepr m1 0 a1, DataDefValue (ValueRepr m2 0 a2)) + -> return (DataDefValue (valueReprNew (max m1 m2) 0 (max a1 a2))) + (ValueRepr 0 n1 a1, DataDefValue (ValueRepr 0 n2 a2)) + -> return (DataDefValue (valueReprNew 0 (max n1 n2) (max a1 a2))) + (ValueRepr m1 n1 a1, DataDefValue (ValueRepr m2 n2 a2)) + -- equal scan fields + | n1 == n2 -> return (DataDefValue (valueReprNew (max m1 m2) n1 (max a1 a2))) + -- non-equal scan fields + | otherwise -> + do if (isVal) + then emitError (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") + else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") + -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ + return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) + _ -> return DataDefNormal + + --------------------------------------------------------- -- Determine the size of a constructor --------------------------------------------------------- @@ -26,22 +150,16 @@ import Type.Type -- order constructor fields of constructors with raw field so the regular fields come first to be scanned. -- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) -- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes -orderConFields :: Monad m => ((Doc -> Doc) -> m ()) -> (Name -> m (Maybe DataInfo)) -> Platform +orderConFields :: Monad m => (Doc -> m ()) -> Doc -> (Name -> m (Maybe DataInfo)) -> Platform -> Int -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) -orderConFields emitError getDataInfo platform extraPreScan fields +orderConFields emitError nameDoc getDataInfo platform extraPreScan fields = do visit ([], [], [], extraPreScan, 0) fields where -- visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) visit (rraw, rmixed, rscan, scanCount0, alignment0) [] = do when (length rmixed > 1) $ - do emitError (\nameDoc -> (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> - text ("hint: use 'box' on either field to make it a non-value type."))) - {- - cs <- getColorScheme - let nameDoc = color (colorCons cs) (pretty cname) - addError range (text "Constructor:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> - text ("hint: use 'box' on either field to make it a non-value type.")) - -} + do emitError (nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + text ("hint: use 'box' on either field to make it a non-value type.")) let -- scancount and size before any mixed and raw fields preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) From 58f836c8af8c9fe713590416f095fccc675a1506 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 23 Feb 2023 11:58:22 -0800 Subject: [PATCH 143/233] wip: make all types reference types unless declared as a value type explicitly --- lib/std/core.kk | 8 +- lib/std/core/hnd.kk | 14 +-- lib/std/core/types.kk | 13 +- lib/std/num/ddouble.kk | 4 +- lib/std/num/decimal.kk | 8 +- lib/std/os/flags.kk | 24 ++-- lib/std/os/path.kk | 6 +- lib/std/time/calendar.kk | 30 ++--- lib/std/time/date.kk | 16 +-- lib/std/time/duration.kk | 4 +- lib/std/time/instant.kk | 2 +- samples/basic/garsia-wachs.kk | 2 +- src/Backend/C/FromCore.hs | 2 +- src/Backend/C/Parc.hs | 6 +- src/Common/Syntax.hs | 10 +- src/Core/Parse.hs | 8 +- src/Kind/Infer.hs | 38 ++++-- src/Kind/Repr.hs | 112 +++++++++++++----- src/Syntax/Parse.hs | 29 +++-- .../vscode/koka.language-koka/package.json | 2 +- .../koka.language-koka/syntaxes/koka.json | 10 +- test/cgen/data1.kk | 18 ++- 22 files changed, 230 insertions(+), 136 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index c6d7881a1..820a816f5 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1368,7 +1368,7 @@ pub fun maximum( xs : list ) : float64 // returned by functions that find sub strings or patterns in // in strings. Use `string:(slice : sslice) -> string` to // create a fresh substring from a slice. -abstract struct sslice( str : string, start : int, len : int ) +abstract value struct sslice( str : string, start : int, len : int ) // Internal export for the regex module pub fun ".new-sslice"( str :string, start: int, len : int ) @@ -1927,7 +1927,7 @@ pub extern unvlist( xs : list ) : vector // Delayed (or _lazy_) values are computed (with effect `:e`) only the first time // `force` is called and cached afterwards. -abstract type delayed +abstract value type delayed con Delay( dref : ref e a,a>> ) // Create a new `:delayed` value. @@ -2231,7 +2231,7 @@ pub fun ".default-exn"(action) show(exn).println // The exception data type -pub struct exception( message :string, info :exception-info ) +pub value struct exception( message :string, info :exception-info ) // Exception information pub open type exception-info @@ -2269,7 +2269,7 @@ pub fun catch( action : () -> a, hndl: exception -> e a) : e a try(action,hndl) // An `:error` type represents a first-class exception result. -pub type error +pub value type error Error( exception : exception ) Ok( result : a ) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 1402c221a..9966f0412 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -39,10 +39,10 @@ extern import // ------------------------------------------- // Each handler in the context has a unique marker. -struct marker( m : int32) +value struct marker( m : int32) // The tag of a handler identifies the type at runtime (e.g. `"exn/core/std"`). -abstract type htagV> +abstract value type htagV> Htag(tagname:string) pub fun ".new-htag"( tag : string ) @@ -252,7 +252,7 @@ value type resume-result Shallow( result: b ) Finalize( result : r ) -type yld +value type yld Pure YieldingFinal Yielding @@ -427,7 +427,7 @@ fun initially-prompt( init : (int) -> e (), res : a ) : e a // Resume context // ------------------------------------------- -abstract struct resume-context( k : resume-result -> e r ) +abstract value struct resume-context( k : resume-result -> e r ) pub fun resume( r : resume-context, x : b ) : e r (r.k)(Deep(x)) @@ -444,7 +444,7 @@ pub fun finalize( r : resume-context, x : r ) : e r // Clauses // ------------------------------------------- -abstract type clause1 +abstract value type clause1 Clause1( clause: (marker, ev, a) -> e b ) inline extern cast-ev0( f : (marker,ev) -> e1 b) : e ((marker,ev) -> e b) @@ -528,7 +528,7 @@ pub fun clause-never1( op : a -> e r ) : clause1 // 0 arguments; reuse 1 argument Clauses //---------------------------------------------------------------- -abstract type clause0 +abstract value type clause0 Clause0( clause: (marker, ev) -> e b ) @@ -574,7 +574,7 @@ pub fun clause-never0( op : () -> e r ) : clause0 // 2 arguments //---------------------------------------------------------------- -abstract type clause2 +abstract value type clause2 Clause2( clause: (marker, ev, a1, a2) -> e b ) fun under2( ev : ev, op : (a1,a2) -> e b, x1 : a1, x2 : a2 ) : e b diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index fd0245f86..cefcb35b4 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -79,7 +79,7 @@ pub value type intptr_t pub value type float32 // An any type. Used for extern calls -pub reference type any +pub type any // Internal type used for in-place update of unique pattern matches pub type reuse @@ -145,10 +145,10 @@ pub type bool pub struct () // A pair of values `:a` and `:b`. -pub struct (,)(fst:a,snd:b) +pub value struct (,)(fst:a,snd:b) // A triple of values. -pub struct (,,)(fst:a,snd:b,thd:c) +pub value struct (,,)(fst:a,snd:b,thd:c) // A quadruple of values. pub struct (,,,)(fst:a,snd:b,thd:c,field4:d) @@ -158,12 +158,12 @@ pub struct (,,,,)(fst:a,snd:b,thd:c,field4:d,field5:e) // The `:maybe` type is used to represent either a value (`Just(x)`) or `Nothing`. // This type is often used to represent values that can be _null_. -pub type maybe +pub value type maybe con Nothing con Just( value : a ) // The choice type represents one of two possible types `:a` or `:b`. -pub type either +pub value type either con Left( left : a ) con Right( right : b ) @@ -177,13 +177,16 @@ pub type order pub value type box con Box( unbox : a ) +/* // Explicitly heap allocate using the `Hbox` constructor. pub reference type hbox con Hbox( unhbox : a ) pub fun hbox( x : a ) : hbox Hbox(x) +*/ +// Prevent inlining an expression by passing it to `keep` (which is a non-inlineable identity function) pub noinline fun keep( x : a ) : a x diff --git a/lib/std/num/ddouble.kk b/lib/std/num/ddouble.kk index 3170eb924..65237b093 100644 --- a/lib/std/num/ddouble.kk +++ b/lib/std/num/ddouble.kk @@ -175,7 +175,7 @@ than arbitrary precision floating point numbers. Internally a `:ddouble` _d_ is represented as a pair of `:float64`s, _hi_ and _lo_, such that the number represented by _d_ is _hi_+_lo_, where \|_lo_\| ≤ 0.5·ulp(_hi_). */ -abstract struct ddouble +abstract value struct ddouble hi : float64 lo : float64 @@ -378,7 +378,7 @@ pub fun max( x : ddouble, y : ddouble ) : ddouble Addition ------------------------------------------------------*/ -struct edouble +value struct edouble num : float64 err : float64 diff --git a/lib/std/num/decimal.kk b/lib/std/num/decimal.kk index dafc1028b..dbc7b20dd 100644 --- a/lib/std/num/decimal.kk +++ b/lib/std/num/decimal.kk @@ -19,10 +19,10 @@ import std/num/float64 // Type of a decimal number. Decimals have arbitrary precision and range and // do exact decimal arithmetic and are well suited for financial calculations for // example. -abstract struct decimal ( - num: int, - exp: int -) +abstract value struct decimal + num : int + exp : int + // The decimal zero. pub val zero : decimal = Decimal(0,0) diff --git a/lib/std/os/flags.kk b/lib/std/os/flags.kk index f75a0631d..d78f2ae0e 100644 --- a/lib/std/os/flags.kk +++ b/lib/std/os/flags.kk @@ -115,33 +115,33 @@ pub fun test( cmdargs ) // Specifies how to handle flags that follow non-flag command line arguments. -pub type flag-order +pub value type flag-order // Allow flags to be permuted with non-flag arguments (default) - con Permute + Permute // flags following non-flag arguments are treated as arguments - con Preorder + Preorder // Wrap each non-flag argument into an flag - con Wrap( wrap : (string) -> a ) + Wrap( wrap : (string) -> a ) // Specifies a single command line flag // For example: `flag("h?",["help"],Bool(Help),"show help information")`. -pub struct flag( - short-names : string, - long-names : list, - parser : flag-parser, +pub struct flag + short-names : string + long-names : list + parser : flag-parser help : string -) + // Specifies the argument of an flag pub type flag-parser // Boolean flag without an argument. // For a flag `foo` Automatically enables forms `--no-foo` and `--foo=true|false`. - con Bool( default : (a,bool) -> a) + Bool( default : (a,bool) -> a) // A required argument. - con Req( parse : (a,string) -> a, help : string ) + Req( parse : (a,string) -> a, help : string ) // An flagal argument. - con Opt( parse : (a,maybe) -> a, help : string ) + Opt( parse : (a,maybe) -> a, help : string ) // Return a nicely formatted string describing the usage of a command, diff --git a/lib/std/os/path.kk b/lib/std/os/path.kk index a036f8415..b8c96e2fd 100644 --- a/lib/std/os/path.kk +++ b/lib/std/os/path.kk @@ -38,10 +38,10 @@ extern import js file "path-inline.js" // A `:path` represents a file system path.\ -abstract struct path( - root : string = "", +abstract value struct path + root : string = "" parts: list = [] // directory parts in reverse order -) + // Return the base name of a path (stem name + extension)\ // `"/foo/bar.txt".path.basename === "bar.txt"` \ diff --git a/lib/std/time/calendar.kk b/lib/std/time/calendar.kk index 81f71d31f..8d29dc97e 100644 --- a/lib/std/time/calendar.kk +++ b/lib/std/time/calendar.kk @@ -27,17 +27,17 @@ extern import js file "calendar-inline.js" // A Calendar determines how a `:date` and `:clock` relates to an `:instant` in time. -abstract struct calendar( - pub name : string, - pub long-name : string, - //timescale : timescale, - pub month-prefix: string, - pub show-era : (date) -> string, - instant-to-dc : (i:instant,tzdelta:duration) -> (date,clock), - dc-to-instant : (date,clock,timezone,timescale) -> instant, - days-to-date : (days:int) -> date, +abstract struct calendar + pub name : string + pub long-name : string + //timescale : timescale + pub month-prefix: string + pub show-era : (date) -> string + instant-to-dc : (i:instant,tzdelta:duration) -> (date,clock) + dc-to-instant : (date,clock,timezone,timescale) -> instant + days-to-date : (days:int) -> date date-to-days : (date:date) -> int -) + // Check if two calendars use the same date calculations. (Display of era names etc. may differ) pub fun (==)( c1 : calendar, c2 : calendar ) : bool @@ -57,11 +57,11 @@ pub fun (==)( c1 : calendar, c2 : calendar ) : bool // The optional `utc-inverse` field returns for an instant in the time zone, the associated UTC time. // By default it returns `Nothing` in which case a generic algorithm is used to determine the // inverse. -abstract struct timezone( - pub name : string, - utc-delta : (instant) -> (duration,string), - utc-inverse: (instant) -> maybe = fn(i) { Nothing } -) +abstract struct timezone + pub name : string + utc-delta : (instant) -> (duration,string) + utc-inverse : (instant) -> maybe = fn(i) { Nothing } + // Same timezone? pub fun (==)( tz1 : timezone, tz2 : timezone ) : bool diff --git a/lib/std/time/date.kk b/lib/std/time/date.kk index 677174e81..6a952298d 100644 --- a/lib/std/time/date.kk +++ b/lib/std/time/date.kk @@ -21,11 +21,11 @@ import std/num/ddouble ----------------------------------------------------------------------------*/ // A date consists of a the year, month, and day. -pub struct date( - year : int, - month: int, +pub value struct date + year : int + month: int day : int -) + // Create an ISO weekdate where the "month" is the ISO week number. pub fun weekdate( year : int, month: int, weekday : weekday ) : date @@ -69,11 +69,11 @@ pub fun (+)( d1 : date, d2 : date ) : date ----------------------------------------------------------------------------*/ // A clock consists of the hour, minute, second, and fractional second (between ``0.0` and `1.0`). -pub struct clock( - hours : int, - minutes : int, +pub struct clock + hours : int + minutes : int seconds : ddouble -) + // Create a clock from a `:duration`; normalizes the clock with seconds and minutes under 60. //pub fun clock( d : duration ) : clock diff --git a/lib/std/time/duration.kk b/lib/std/time/duration.kk index 1e09b8f99..746062417 100644 --- a/lib/std/time/duration.kk +++ b/lib/std/time/duration.kk @@ -21,9 +21,9 @@ import std/time/timestamp // A duration in time in (TAI) SI seconds (as measured on the earth's geoid).\ // A duration is represented by a `:ddouble` giving it a high range and precision (see the [`instant`](std_time_instant.html) module) -abstract struct duration( +abstract value struct duration secs : timespan -) + // A zero duration. pub val zero : duration = Duration(timespan0) diff --git a/lib/std/time/instant.kk b/lib/std/time/instant.kk index 681a21ee1..72f0a5926 100644 --- a/lib/std/time/instant.kk +++ b/lib/std/time/instant.kk @@ -127,7 +127,7 @@ efficiency and precision. They automatically convert between different time scal when necessary (for example when comparing instants in time, or calculating durations between UTC calendar times). */ -abstract struct instant +abstract value struct instant since : timestamp // time since the 2000-01-01 in the timescale ts : timescale // the time scale (TAI, UTC, etc) diff --git a/samples/basic/garsia-wachs.kk b/samples/basic/garsia-wachs.kk index 791014b31..72aa0ffdc 100644 --- a/samples/basic/garsia-wachs.kk +++ b/samples/basic/garsia-wachs.kk @@ -25,7 +25,7 @@ fun show( t : tree ) : string //---------------------------------------------------- // Non empty lists //---------------------------------------------------- -pub type list1 +pub value type list1 Cons1( head : a, tail : list ) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 09808e2dc..b5e15c9ba 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -684,7 +684,7 @@ genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount else -} vcat((if not (isConAsJust conRepr) then [] else let arg = ppName (fst (head (conInfoParams con))) - in [text "if kk_likely(!kk_box_is_maybe(" <.> arg <.> text ")) { return kk_datatype_as_Just(" <.> arg <.> text "); }" + in [text "if kk_likely(!kk_box_is_maybe" <.> arguments [arg] <.> text ") { return kk_datatype_as_Just(" <.> arg <.> text "); }" ]) ++ [text "struct" <+> nameDoc <.> text "*" <+> tmp <+> text "=" diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 4ef0978d8..f0666cb4c 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -688,7 +688,7 @@ genDupDrop isDup tname mbConRepr mbScanCount else let normal = (Just (dupDropFun isDup tp mbConRepr mbScanCount (Var tname InfoNone))) in case mbDi of Just di -> case (dataInfoDef di, dataInfoConstrs di, snd (getDataRepr di)) of - (DataDefNormal, [conInfo], [conRepr]) -- data with just one constructor + (DataDefNormal _, [conInfo], [conRepr]) -- data with just one constructor -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) @@ -1004,7 +1004,7 @@ getDataDef' :: Newtypes -> Type -> Maybe DataDef getDataDef' newtypes tp = case getDataInfo' newtypes tp of Just di -> Just (dataInfoDef di) - _ -> Nothing -- DataDefNormal + _ -> Nothing -- DataDefNormal False getDataInfo :: Type -> Parc (Maybe DataInfo) @@ -1027,7 +1027,7 @@ getDataDef tp = do newtypes <- getNewtypes return (case getDataDef' newtypes tp of Just dd -> dd - Nothing -> DataDefNormal) + Nothing -> DataDefNormal False) extractDataDefType :: Type -> Maybe Name diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index b726afd2e..29e56b03f 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -183,8 +183,8 @@ instance Show DataKind where show Retractive = "rectype" data DataDef = DataDefValue !ValueRepr - | DataDefNormal - | DataDefAuto -- Value or Normal; determined by kind inference + | DataDefNormal{ dataDefDeclAsRef :: Bool } + -- | DataDefAuto -- Value or Normal; determined by kind inference | DataDefRec | DataDefOpen deriving Eq @@ -195,13 +195,13 @@ instance Show DataDef where DataDefNormal{} -> "normal" DataDefRec -> "rec" DataDefOpen -> "open" - DataDefAuto -> "auto" + -- DataDefAuto -> "auto" dataDefIsRec ddef = case ddef of DataDefValue{} -> False - DataDefNormal -> False - DataDefAuto -> False + DataDefNormal{} -> False + -- DataDefAuto -> False _ -> True dataDefIsOpen ddef diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 75ff16122..d263fbcb0 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -280,7 +280,7 @@ typeSort (ddef0,isExtend,sort) <- parseTypeMod (_,doc) <- dockeyword "type" let ddef = case (isRecursive, ddef0) of - (True,DataDefNormal) -> DataDefRec + (True,DataDefNormal True) -> DataDefRec _ -> ddef0 return (ddef,isExtend,sort,doc) @@ -291,9 +291,9 @@ parseTypeMod <|> do specialId "value" vrepr <- parseValueRepr return (DataDefValue vrepr, False, Inductive) - <|> do{ specialId "co"; return (DataDefNormal, False, CoInductive) } - <|> do{ specialId "rec"; return (DataDefNormal, False, Retractive) } - <|> return (DataDefNormal, False, Inductive) + <|> do{ specialId "co"; return (DataDefNormal True, False, CoInductive) } + <|> do{ specialId "rec"; return (DataDefNormal True, False, Retractive) } + <|> return (DataDefNormal False, False, Inductive) "" parseValueRepr :: LexParser ValueRepr diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index b5c5427fc..0954bc48c 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -827,24 +827,40 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then do addError range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> text " hint: declare it as a 'type rec' (or 'effect rec)' to allow negative occurrences") else return () - + + -- create datadef and conInfos with correct ValueRepr and ordered fields let emitError d = addError range (text "Type" <+> nameDoc <+> d) - emitWarning d = addWarning range (text "Type" <+> nameDoc <+> d) + emitWarning d = addWarning range (text "Type" <+> nameDoc <+> d) + resultHasKindStar = hasKindStarResult (getKind typeResult) + maxMembers = maximum ([0] ++ map (length . conInfoParams) conInfos0) + conCount = length conInfos0 + willNeedStructTag = dataDefIsValue ddef && conCount > 1 && maxMembers >= 1 + extraFields = if (dataDefIsOpen ddef) then 1 {- open datatype tag -} + else if willNeedStructTag then 1 {- explicit struct tag -} + else 0 platform <- getPlatform - (ddef1,conInfos) + (ddef1,conInfos1) <- createDataDef emitError emitWarning lookupDataInfo - platform qname (hasKindStarResult (getKind typeResult)) isRec sort - (if dataDefIsOpen ddef then 1 else 0) ddef conInfos0 + platform qname resultHasKindStar isRec sort extraFields ddef conInfos0 + + let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos1 range ddef1 vis doc + + assertion ("Kind.Infer.resolveTypeDef: assuming value struct tag but not inferred as such " ++ show (ddef,ddef1)) + ((willNeedStructTag && Core.needsTagField (fst (Core.getDataRepr dataInfo))) || not willNeedStructTag) $ return () + - let dataInfo0 = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos range ddef1 vis doc + {- + -- adjust datainfo in case an extra value tag was needed dataInfo <- case ddef1 of DataDefValue (ValueRepr m n a) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) - -> -- add extra required tag field to the size - -- todo: recalculate the constructor sizes as well! - do let ddef2 = DataDefValue (valueReprNew m (n+1) a) - return $ dataInfo0{ dataInfoDef = ddef2 } + -> -- recalculate with extra required tag field to the size + do (ddef2,conInfos2) <- createDataDef emitError emitWarning lookupDataInfo + platform qname resultHasKindStar isRec sort + 1 {- extra field for tag -} ddef1 {- guarantees value type again -} conInfos1 + let dataInfo1 = dataInfo0{ dataInfoDef = ddef2, dataInfoConstrs = conInfos2 } + return dataInfo1 _ -> return dataInfo0 - + -} -- trace (showTypeBinder newtp') $ addRangeInfo range (Decl (show sort) (getName newtp') (mangleTypeName (getName newtp'))) return (Core.Data dataInfo isExtend) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 71daa5bb6..2726f7186 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -34,43 +34,93 @@ createDataDef emitError emitWarning lookupDataInfo extraFields defaultDef conInfos0 = do --calculate the value repr of each constructor conInfos <- mapM createConInfoRepr conInfos0 + -- datadef + let maxMembers = maximum ([0] ++ map (length . conInfoParams) conInfos) + conCount = length conInfos + canbeValue = resultHasKindStar && sort /= Retractive + isEnum = canbeValue && maxMembers == 0 && conCount >= 1 + isIso = canbeValue && maxMembers == 1 && conCount == 1 + ddef <- case defaultDef of - DataDefNormal - -> return (if (isRec) then DataDefRec else DataDefNormal) - DataDefValue{} | isRec - -> do emitError $ text "cannot be declared as a value type since it is recursive." - return defaultDef - DataDefAuto | isRec - -> return DataDefRec - -- DataDefAuto | isAsMaybe - -- -> return DataDefNormal DataDefOpen -> return DataDefOpen DataDefRec -> return DataDefRec + DataDefNormal{} | isRec + -> return DataDefRec + DataDefNormal declAsRef + -> do dd <- createMaxDataDef conInfos + case dd of + DataDefValue vr | isEnum + -> return dd + DataDefValue vr | isIso -- iso types are always value types + -> return dd + DataDefValue vr + -> do let wouldGetTagField = (conCount > 1 && not isEnum) + size = valueReprSize platform vr + (if wouldGetTagField then sizeField platform else 0) + when (not declAsRef && + -- ((size <= 3*sizePtr platform && conCount == 1) || (size <= 2*sizePtr platform && conCount > 1)) + (size <= 2*sizePtr platform) && (maxMembers <= 3) && canbeValue) $ + emitWarning $ text "may be better declared as a value type for efficiency (e.g. 'value type/struct')" <-> + text "or declare as a reference type (e.g. 'ref type/struct') to suppress this warning" + return (DataDefNormal declAsRef) + _ -> return (DataDefNormal declAsRef) + DataDefValue{} | isRec + -> do emitError $ text "cannot be declared as a value type since it is recursive." + return (DataDefNormal False) + DataDefValue{} | not resultHasKindStar + -> do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? + return (DataDefNormal False) + DataDefValue{} | sort == Retractive + -> do emitError $ text "is declared as a value type but is not (co)inductive." + return (DataDefNormal False) + DataDefValue{} + -> do dd <- createMaxDataDef conInfos + case dd of + DataDefValue vr + -> do let size = valueReprSize platform vr + when (size > 4*sizePtr platform) $ + emitWarning (text "requires" <+> pretty size <+> text "bytes which is rather large for a value type") + when isEnum $ + emitWarning (text "is an enumeration -- there is no need to declare it as a value type") + -- when isIso $ + -- emitWarning (text "is a isomorphic type -- there is no need to declare it as a value type") + return dd + _ -> do emitError $ text "cannot be used as a value type." -- should never happen? + return (DataDefNormal False) + + + -- DataDefAuto | isRec + -- -> return DataDefRec + {- _ -- Value or auto, and not recursive -> -- determine the raw fields and total size do dd <- createMaxDataDef conInfos case (defaultDef,dd) of -- note: m = raw, n = scan (DataDefValue _, DataDefValue vr) - -> if resultHasKindStar - then return (DataDefValue vr) - else do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? - return DataDefNormal + -> assertion ("Kind.Repr: value type is not kind star and/or recursive") (resultHasKindStar && not isRec) $ + return (DataDefValue vr) (DataDefValue _, DataDefNormal) -> do emitError $ text "cannot be used as a value type." -- should never happen? return DataDefNormal (DataDefAuto, DataDefValue vr) - -> if (valueReprSize platform vr <= 3*(sizePtr platform) -- not too large in bytes - && maximum (map (length . conInfoParams) conInfos) <= 3 -- and at most 3 members - && resultHasKindStar - && (sort /= Retractive)) - then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ - return (DataDefValue vr) - else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ - return (DataDefNormal) - _ -> return DataDefNormal + -> do let maxMembers = maximum (map (length . conInfoParams) conInfos) + conCount = length conInfos + -- default to a value type? + if ( -- not too large: 24 bytes, or 16 with multiple constructors (since a tag is needed as well) + -- use fixed bytes to be more portable + ((conCount == 1 && valueReprSize platform vr <= 24) || (conCount > 1 && valueReprSize platform vr <= 16)) + -- and at most three members + && (maximum (map (length . conInfoParams) conInfos) <= 3) + -- and has star kind and is (co)inductive + && resultHasKindStar && (sort /= Retractive)) + then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ + return (DataDefValue vr) + else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ + return (DataDefNormal) + _ -> return DataDefNormal + -} return (ddef,conInfos) where isVal :: Bool @@ -99,7 +149,7 @@ createDataDef emitError emitWarning lookupDataInfo -- maxDataDefs :: Monad m => [ValueRepr] -> m DataDef maxDataDefs [] = if not isVal - then return DataDefNormal -- reference type, no constructors + then return (DataDefNormal False) -- reference type, no constructors else do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) then 4 else if (name == nameTpFloat || name == nameTpInt64) @@ -134,13 +184,13 @@ createDataDef emitError emitWarning lookupDataInfo | n1 == n2 -> return (DataDefValue (valueReprNew (max m1 m2) n1 (max a1 a2))) -- non-equal scan fields | otherwise -> - do if (isVal) - then emitError (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> - text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") - else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") + do when isVal $ + emitError (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") + -- else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ - return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) - _ -> return DataDefNormal + return (DataDefNormal False) -- (DataDefValue (max m1 m2) (max n1 n2)) + _ -> return (DataDefNormal False) --------------------------------------------------------- @@ -217,8 +267,8 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields getDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m (Maybe DataDef) getDataDef lookupDI tp = case extractDataDefType tp of - Nothing -> return $ Just DataDefNormal - Just name | name == nameTpBox -> return $ Just DataDefNormal + Nothing -> return $ Just (DataDefNormal False) + Just name | name == nameTpBox -> return $ Just (DataDefNormal False) Just name -> do mdi <- lookupDI name case mdi of Nothing -> return Nothing diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 810b2b322..e6fedc7fc 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -564,8 +564,10 @@ structDecl dvis = do (vis,dvis,rng) <- do{ rng <- keyword "abstract"; return (Public,Private,rng) } <|> do{ (vis,rng) <- visibility dvis; return (vis,vis,rng) } ddef <- do { specialId "value"; return (DataDefValue valueReprZero) } - <|> do { specialId "reference"; return DataDefNormal } - <|> do { return DataDefAuto } + <|> do { specialIdOr "ref" ["reference"]; + -- pwarningMessage "using 'reference' is deprecated and is always the default now"; + return (DataDefNormal True) } + <|> do { return (DataDefNormal False) } (trng,doc) <- dockeyword "struct" return (vis,dvis,ddef,rng,trng,doc)) @@ -601,15 +603,17 @@ typeDeclKind do (rng1,kind) <- do{ rng <- specialId "rec"; return (rng,Retractive) } <|> do{ rng <- specialId "co"; return (rng,CoInductive) } (rng2,doc) <- dockeyword "type" - return (kind,combineRanges [rng1,rng2],doc,DataDefNormal,False) + return (kind,combineRanges [rng1,rng2],doc,DataDefNormal True,False) ) <|> try( do (ddef,isExtend) <- do { specialId "open"; return (DataDefOpen, False) } <|> do { specialId "extend"; return (DataDefOpen, True) } <|> do { specialId "value"; return (DataDefValue valueReprZero, False) } - <|> do { specialId "reference"; return (DataDefNormal, False) } - <|> return (DataDefAuto, False) + <|> do { specialIdOr "ref" ["reference"]; + -- pwarningMessage "using 'reference' is deprecated and is always the default now"; + return (DataDefNormal True, False) } + <|> return (DataDefNormal False, False) (rng,doc) <- dockeyword "type" return (Inductive,rng,doc,ddef,isExtend)) @@ -818,14 +822,14 @@ makeEffectDecl decl = evName = newName "ev" evFld = ValueBinder evName evTp Nothing irng rng evCon = UserCon (toConstructorName id) [] [(Private,evFld)] Nothing irng rng Private "" - in (DataType ename tpars [evCon] rng vis Inductive (DataDefAuto {-DataDefValue 0 0-}) False docx + in (DataType ename tpars [evCon] rng vis Inductive (DataDefNormal True {-DataDefValue 0 0-}) False docx ,(\action -> Lam [ValueBinder evName Nothing Nothing irng rng] (App (action) [(Nothing,App (Var (toConstructorName id) False rng) [(Nothing,Var evName False rng)] rng)] rng) rng)) else let -- add a private constructor that refers to the handler type to get a proper recursion check hndfld = ValueBinder nameNil hndTp Nothing irng irng hndcon = UserCon (toConstructorName id) [hndEffTp,hndResTp] [(Private,hndfld)] Nothing irng irng Private "" - in (DataType ename tpars [hndcon] rng vis Inductive DataDefAuto False docx, \action -> action) + in (DataType ename tpars [hndcon] rng vis Inductive (DataDefNormal True) False docx, \action -> action) -- declare the effect handler type kindEffect = KindCon nameKindEffect krng @@ -866,7 +870,7 @@ makeEffectDecl decl = getOpName (OpDecl (doc,opId,_,idrng,linear,opSort,exists0,pars,prng,mbteff,tres)) = show (unqualify opId) hndCon = UserCon (toConstructorName hndName) [] [(Public,fld) | fld <- opFields] Nothing krng grng vis "" - hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] grng vis sort DataDefNormal False ("// handlers for the " ++ docEffect) + hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] grng vis sort (DataDefNormal True) False ("// handlers for the " ++ docEffect) -- declare the handle function @@ -2767,6 +2771,15 @@ special s show s +specialIdOr :: String -> [String] -> LexParser Range +specialIdOr kw [] = specialId kw +specialIdOr kw deprecated + = choice (specialId kw : map deprecate deprecated) + where + deprecate k = do rng <- specialId k + warnDeprecated k kw + return rng + keywordOr :: String -> [String] -> LexParser Range keywordOr kw [] = keyword kw diff --git a/support/vscode/koka.language-koka/package.json b/support/vscode/koka.language-koka/package.json index e8e3f2e53..38f9d28e3 100644 --- a/support/vscode/koka.language-koka/package.json +++ b/support/vscode/koka.language-koka/package.json @@ -2,7 +2,7 @@ "name": "language-koka", "displayName": "Koka Syntax Highlighting", "description": "Official syntax support for the Koka programming language.", - "version": "2.0.4", + "version": "2.0.5", "publisher": "koka", "engines": { "vscode": "^1.0.0" diff --git a/support/vscode/koka.language-koka/syntaxes/koka.json b/support/vscode/koka.language-koka/syntaxes/koka.json index a534b6c5d..52e586a0c 100644 --- a/support/vscode/koka.language-koka/syntaxes/koka.json +++ b/support/vscode/koka.language-koka/syntaxes/koka.json @@ -474,7 +474,7 @@ "top_type": { "begin": "(:(?![$%&\\*\\+@!\\\\\\^~=\\.:\\-\\|<>]))|(where|iff|when)(?![\\w\\-])" - , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|value|reference|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|value|ref|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "constant.numeric.type support.type koka.type" }, "2" : { "name": "keyword koka.keyword.$2" } } , "endCaptures": { "0" : { "name": "invalid.keyword koka.invalid" }} @@ -485,8 +485,8 @@ "top_type_type": - { "begin": "((?:(?:value|reference|open|extend|rec|co)?\\s*type)|(?:named\\s+)?(?:scoped\\s+)?(?:linear\\s+)?(?:rec\\s+)?(?:effect|context|ambient))\\s+(?!fn|fun|val|raw|final|ctl|ret)([a-z][\\w\\-]+|<>|<\\|>|\\(,*\\))" - , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|reference|open|extend|inline|noinline)(?![\\w\\-?']))" + { "begin": "((?:(?:value|ref|open|extend|rec|co)?\\s*type)|(?:named\\s+)?(?:scoped\\s+)?(?:linear\\s+)?(?:rec\\s+)?(?:effect|context|ambient))\\s+(?!fn|fun|val|raw|final|ctl|ret)([a-z][\\w\\-]+|<>|<\\|>|\\(,*\\))" + , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|ref|open|extend|inline|noinline)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration.type koka.keyword" } , "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }} , "endCaptures": { "0": { "name": "punctuation.separator koka.special" }} @@ -511,7 +511,7 @@ }, "top_type_struct": - { "match": "(struct)\\s+([a-z][\\w\\-]*|\\(,*\\))" + { "match": "((?:(?:value|ref)\\s*)?struct)\\s+([a-z][\\w\\-]*|\\(,*\\))" , "captures": { "1": { "name": "keyword.declaration koka.keyword.struct" }, "2": { "name": "constant.numeric.type support.type koka.type.typecon" } @@ -519,7 +519,7 @@ }, "top_type_struct_args": - { "begin": "(struct)\\s+([a-z][\\w\\-]*|\\(,*\\))\\s*(<)" + { "begin": "((?:(?:value|ref)\\s*)?struct)\\s+([a-z][\\w\\-]*|\\(,*\\))\\s*(<)" , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration koka.keyword.struct" }, "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }, diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index 758971704..d3dfdbc6d 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -22,7 +22,7 @@ type bool { False; True } type iso { Iso(x:int) } // single struct -type pair { Pair(x:a, y:b) } +value type pair { Pair(x:a, y:b) } type triple { Triple(p:pair,z:c) } @@ -41,8 +41,20 @@ type vstrct { VStrct( x:a, i:int ); VStrct2(d:float64,s:string); VStrct3(i:in // struct type strct { Strct( x:a, i:int ); Strct2(i:int, s:string); Strct3(x:a) } -// struct -type maybe { Just(x:a); Nothing } +// reference maybe +ref type rmaybe { RJust(x:a); RNothing } + +fun test-rmaybe( m : rmaybe ) : int + match m + RJust(i) -> i + RNothing -> 0 + +value type vmaybe { VJust(x:a); VNothing } + +fun test-vmaybe( m : vmaybe ) : int + match m + VJust(i) -> i + VNothing -> 0 // normal type normal { One(x:a,y:pair,z:pair); Two(x:int); Three } From fb9bc0864dd479ccf100d5be8c5fe49fe4b13ec0 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 23 Feb 2023 16:48:33 -0800 Subject: [PATCH 144/233] wip: cleanup Repr --- src/Backend/C/Parc.hs | 6 +-- src/Common/Syntax.hs | 14 +++--- src/Core/Parse.hs | 8 ++-- src/Kind/Repr.hs | 103 +++++++++++++++++------------------------- src/Syntax/Parse.hs | 17 ++++--- test/cgen/data1.kk | 2 + 6 files changed, 65 insertions(+), 85 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index f0666cb4c..4ef0978d8 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -688,7 +688,7 @@ genDupDrop isDup tname mbConRepr mbScanCount else let normal = (Just (dupDropFun isDup tp mbConRepr mbScanCount (Var tname InfoNone))) in case mbDi of Just di -> case (dataInfoDef di, dataInfoConstrs di, snd (getDataRepr di)) of - (DataDefNormal _, [conInfo], [conRepr]) -- data with just one constructor + (DataDefNormal, [conInfo], [conRepr]) -- data with just one constructor -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) @@ -1004,7 +1004,7 @@ getDataDef' :: Newtypes -> Type -> Maybe DataDef getDataDef' newtypes tp = case getDataInfo' newtypes tp of Just di -> Just (dataInfoDef di) - _ -> Nothing -- DataDefNormal False + _ -> Nothing -- DataDefNormal getDataInfo :: Type -> Parc (Maybe DataInfo) @@ -1027,7 +1027,7 @@ getDataDef tp = do newtypes <- getNewtypes return (case getDataDef' newtypes tp of Just dd -> dd - Nothing -> DataDefNormal False) + Nothing -> DataDefNormal) extractDataDefType :: Type -> Maybe Name diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 29e56b03f..9a502c928 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -182,26 +182,26 @@ instance Show DataKind where show CoInductive = "cotype" show Retractive = "rectype" -data DataDef = DataDefValue !ValueRepr - | DataDefNormal{ dataDefDeclAsRef :: Bool } - -- | DataDefAuto -- Value or Normal; determined by kind inference +data DataDef = DataDefValue !ValueRepr -- value type + | DataDefNormal -- reference type | DataDefRec | DataDefOpen + | DataDefAuto -- Value or Normal; determined by kind inference deriving Eq instance Show DataDef where show dd = case dd of DataDefValue v -> "val" ++ show v - DataDefNormal{} -> "normal" + DataDefNormal -> "normal" DataDefRec -> "rec" DataDefOpen -> "open" - -- DataDefAuto -> "auto" + DataDefAuto -> "auto" dataDefIsRec ddef = case ddef of DataDefValue{} -> False - DataDefNormal{} -> False - -- DataDefAuto -> False + DataDefNormal -> False + DataDefAuto -> False _ -> True dataDefIsOpen ddef diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index d263fbcb0..75ff16122 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -280,7 +280,7 @@ typeSort (ddef0,isExtend,sort) <- parseTypeMod (_,doc) <- dockeyword "type" let ddef = case (isRecursive, ddef0) of - (True,DataDefNormal True) -> DataDefRec + (True,DataDefNormal) -> DataDefRec _ -> ddef0 return (ddef,isExtend,sort,doc) @@ -291,9 +291,9 @@ parseTypeMod <|> do specialId "value" vrepr <- parseValueRepr return (DataDefValue vrepr, False, Inductive) - <|> do{ specialId "co"; return (DataDefNormal True, False, CoInductive) } - <|> do{ specialId "rec"; return (DataDefNormal True, False, Retractive) } - <|> return (DataDefNormal False, False, Inductive) + <|> do{ specialId "co"; return (DataDefNormal, False, CoInductive) } + <|> do{ specialId "rec"; return (DataDefNormal, False, Retractive) } + <|> return (DataDefNormal, False, Inductive) "" parseValueRepr :: LexParser ValueRepr diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 2726f7186..50542298a 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -47,9 +47,21 @@ createDataDef emitError emitWarning lookupDataInfo -> return DataDefOpen DataDefRec -> return DataDefRec - DataDefNormal{} | isRec + + DataDefNormal | isRec -> return DataDefRec - DataDefNormal declAsRef + DataDefNormal + -> do dd <- createMaxDataDef conInfos + case dd of + DataDefValue vr | isEnum + -> return dd + DataDefValue vr | isIso -- iso types are always value types + -> return dd + _ -> return DataDefNormal + + DataDefAuto | isRec + -> return DataDefRec + DataDefAuto -> do dd <- createMaxDataDef conInfos case dd of DataDefValue vr | isEnum @@ -59,27 +71,26 @@ createDataDef emitError emitWarning lookupDataInfo DataDefValue vr -> do let wouldGetTagField = (conCount > 1 && not isEnum) size = valueReprSize platform vr + (if wouldGetTagField then sizeField platform else 0) - when (not declAsRef && - -- ((size <= 3*sizePtr platform && conCount == 1) || (size <= 2*sizePtr platform && conCount > 1)) - (size <= 2*sizePtr platform) && (maxMembers <= 3) && canbeValue) $ + when ((size <= 2*sizePtr platform) && (maxMembers <= 3) && canbeValue) $ emitWarning $ text "may be better declared as a value type for efficiency (e.g. 'value type/struct')" <-> text "or declare as a reference type (e.g. 'ref type/struct') to suppress this warning" - return (DataDefNormal declAsRef) - _ -> return (DataDefNormal declAsRef) + return DataDefNormal + _ -> return DataDefNormal + DataDefValue{} | isRec -> do emitError $ text "cannot be declared as a value type since it is recursive." - return (DataDefNormal False) + return DataDefNormal DataDefValue{} | not resultHasKindStar -> do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? - return (DataDefNormal False) + return DataDefNormal DataDefValue{} | sort == Retractive -> do emitError $ text "is declared as a value type but is not (co)inductive." - return (DataDefNormal False) + return DataDefNormal DataDefValue{} -> do dd <- createMaxDataDef conInfos case dd of DataDefValue vr - -> do let size = valueReprSize platform vr + -> do let size = valueReprSize platform vr when (size > 4*sizePtr platform) $ emitWarning (text "requires" <+> pretty size <+> text "bytes which is rather large for a value type") when isEnum $ @@ -88,39 +99,7 @@ createDataDef emitError emitWarning lookupDataInfo -- emitWarning (text "is a isomorphic type -- there is no need to declare it as a value type") return dd _ -> do emitError $ text "cannot be used as a value type." -- should never happen? - return (DataDefNormal False) - - - -- DataDefAuto | isRec - -- -> return DataDefRec - {- - _ -- Value or auto, and not recursive - -> -- determine the raw fields and total size - do dd <- createMaxDataDef conInfos - case (defaultDef,dd) of -- note: m = raw, n = scan - (DataDefValue _, DataDefValue vr) - -> assertion ("Kind.Repr: value type is not kind star and/or recursive") (resultHasKindStar && not isRec) $ - return (DataDefValue vr) - (DataDefValue _, DataDefNormal) - -> do emitError $ text "cannot be used as a value type." -- should never happen? return DataDefNormal - (DataDefAuto, DataDefValue vr) - -> do let maxMembers = maximum (map (length . conInfoParams) conInfos) - conCount = length conInfos - -- default to a value type? - if ( -- not too large: 24 bytes, or 16 with multiple constructors (since a tag is needed as well) - -- use fixed bytes to be more portable - ((conCount == 1 && valueReprSize platform vr <= 24) || (conCount > 1 && valueReprSize platform vr <= 16)) - -- and at most three members - && (maximum (map (length . conInfoParams) conInfos) <= 3) - -- and has star kind and is (co)inductive - && resultHasKindStar && (sort /= Retractive)) - then -- trace ("default to value: " ++ show name ++ ": " ++ show vr) $ - return (DataDefValue vr) - else -- trace ("default to reference: " ++ show name ++ ": " ++ show vr ++ ", " ++ show (valueReprSize platform vr)) $ - return (DataDefNormal) - _ -> return DataDefNormal - -} return (ddef,conInfos) where isVal :: Bool @@ -149,7 +128,7 @@ createDataDef emitError emitWarning lookupDataInfo -- maxDataDefs :: Monad m => [ValueRepr] -> m DataDef maxDataDefs [] = if not isVal - then return (DataDefNormal False) -- reference type, no constructors + then return DataDefNormal -- reference type, no constructors else do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) then 4 else if (name == nameTpFloat || name == nameTpInt64) @@ -189,8 +168,8 @@ createDataDef emitError emitWarning lookupDataInfo text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") -- else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ - return (DataDefNormal False) -- (DataDefValue (max m1 m2) (max n1 n2)) - _ -> return (DataDefNormal False) + return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) + _ -> return DataDefNormal --------------------------------------------------------- @@ -205,7 +184,7 @@ orderConFields :: Monad m => (Doc -> m ()) -> Doc -> (Name -> m (Maybe DataInfo) orderConFields emitError nameDoc getDataInfo platform extraPreScan fields = do visit ([], [], [], extraPreScan, 0) fields where - -- visit :: ([((Name,Type),Int,Int,Int)],[((Name,Type),Int,Int,Int)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) + -- visit :: ([((Name,Type),ValueRepr)],[((Name,Type),ValueRepr)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) visit (rraw, rmixed, rscan, scanCount0, alignment0) [] = do when (length rmixed > 1) $ do emitError (nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> @@ -217,11 +196,11 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields -- (or otherwise the C compiler may insert uninitialized padding) (padding,mixedScan) = case rmixed of - ((_,_,scan,ralign):_) + ((_,ValueRepr _ scan ralign):_) -> let padSize = preSize `mod` ralign padCount = padSize `div` sizeField platform in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ - ([((newPaddingName (scanCount0 + i),typeAny),sizeField platform,1,sizeField platform) | i <- [1..padCount]] + ([((newPaddingName (scanCount0 + i),typeAny),valueReprScan 1) | i <- [1..padCount]] ,scan + padCount) [] -> ([],0) @@ -229,8 +208,8 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields scanCount = scanCount0 + mixedScan alignment = if scanCount > 0 then max alignment0 (sizeField platform) else alignment0 rest = padding ++ rmixed ++ reverse rraw - restSizes = [size | (_field,size,_scan,_align) <- rest] - restFields= [field | (field,_size,_scan,_align) <- rest] + restSizes = [valueReprSize platform vr | (_field,vr) <- rest] + restFields= [field | (field,_vr) <- rest] size = alignedSum preSize restSizes rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) vrepr = valueReprNew rawSize scanCount alignment @@ -240,25 +219,25 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) = do mDataDef <- getDataDef getDataInfo tp case mDataDef of - Just (DataDefValue (ValueRepr raw scan align)) + Just (DataDefValue vr@(ValueRepr raw scan align)) -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors let alignment = max align alignment0 in if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) -- but we count them to be sure (and for function data) - visit (rraw, (field,raw,scan,align):rmixed, rscan, scanCount, alignment) fs + visit (rraw, (field,vr):rmixed, rscan, scanCount, alignment) fs else if (raw > 0) - then visit (insertRaw field raw scan align rraw, rmixed, rscan, scanCount, alignment) fs + then visit (insertRaw field vr rraw, rmixed, rscan, scanCount, alignment) fs else visit (rraw, rmixed, field:rscan, scanCount + scan, alignment) fs _ -> visit (rraw, rmixed, field:rscan, scanCount + 1, alignment0) fs -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype - insertRaw :: (Name,Type) -> Int -> Int -> Int -> [((Name,Type),Int,Int,Int)] -> [((Name,Type),Int,Int,Int)] - insertRaw field raw scan align ((f,r,s,a):rs) - | align <= a = (field,raw,scan,align):(f,r,s,a):rs - | otherwise = (f,r,s,a):insertRaw field raw scan align rs - insertRaw field raw scan align [] - = [(field,raw,scan,align)] + insertRaw :: (Name,Type) -> ValueRepr -> [((Name,Type),ValueRepr)] -> [((Name,Type),ValueRepr)] + insertRaw field vr ((f,vrf):rs) + | valueReprAlignment vr <= valueReprAlignment vrf = (field,vr):(f,vrf):rs + | otherwise = (f,vrf):insertRaw field vr rs + insertRaw field vr [] + = [(field,vr)] @@ -267,8 +246,8 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields getDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m (Maybe DataDef) getDataDef lookupDI tp = case extractDataDefType tp of - Nothing -> return $ Just (DataDefNormal False) - Just name | name == nameTpBox -> return $ Just (DataDefNormal False) + Nothing -> return $ Just DataDefNormal + Just name | name == nameTpBox -> return $ Just DataDefNormal Just name -> do mdi <- lookupDI name case mdi of Nothing -> return Nothing diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index e6fedc7fc..c0f8f9756 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -566,8 +566,8 @@ structDecl dvis = ddef <- do { specialId "value"; return (DataDefValue valueReprZero) } <|> do { specialIdOr "ref" ["reference"]; -- pwarningMessage "using 'reference' is deprecated and is always the default now"; - return (DataDefNormal True) } - <|> do { return (DataDefNormal False) } + return DataDefNormal } + <|> do { return DataDefAuto } (trng,doc) <- dockeyword "struct" return (vis,dvis,ddef,rng,trng,doc)) @@ -603,7 +603,7 @@ typeDeclKind do (rng1,kind) <- do{ rng <- specialId "rec"; return (rng,Retractive) } <|> do{ rng <- specialId "co"; return (rng,CoInductive) } (rng2,doc) <- dockeyword "type" - return (kind,combineRanges [rng1,rng2],doc,DataDefNormal True,False) + return (kind,combineRanges [rng1,rng2],doc,DataDefNormal,False) ) <|> try( @@ -611,9 +611,8 @@ typeDeclKind <|> do { specialId "extend"; return (DataDefOpen, True) } <|> do { specialId "value"; return (DataDefValue valueReprZero, False) } <|> do { specialIdOr "ref" ["reference"]; - -- pwarningMessage "using 'reference' is deprecated and is always the default now"; - return (DataDefNormal True, False) } - <|> return (DataDefNormal False, False) + return (DataDefNormal, False) } + <|> return (DataDefAuto, False) (rng,doc) <- dockeyword "type" return (Inductive,rng,doc,ddef,isExtend)) @@ -822,14 +821,14 @@ makeEffectDecl decl = evName = newName "ev" evFld = ValueBinder evName evTp Nothing irng rng evCon = UserCon (toConstructorName id) [] [(Private,evFld)] Nothing irng rng Private "" - in (DataType ename tpars [evCon] rng vis Inductive (DataDefNormal True {-DataDefValue 0 0-}) False docx + in (DataType ename tpars [evCon] rng vis Inductive (DataDefNormal {-DataDefValue 0 0-}) False docx ,(\action -> Lam [ValueBinder evName Nothing Nothing irng rng] (App (action) [(Nothing,App (Var (toConstructorName id) False rng) [(Nothing,Var evName False rng)] rng)] rng) rng)) else let -- add a private constructor that refers to the handler type to get a proper recursion check hndfld = ValueBinder nameNil hndTp Nothing irng irng hndcon = UserCon (toConstructorName id) [hndEffTp,hndResTp] [(Private,hndfld)] Nothing irng irng Private "" - in (DataType ename tpars [hndcon] rng vis Inductive (DataDefNormal True) False docx, \action -> action) + in (DataType ename tpars [hndcon] rng vis Inductive DataDefNormal False docx, \action -> action) -- declare the effect handler type kindEffect = KindCon nameKindEffect krng @@ -870,7 +869,7 @@ makeEffectDecl decl = getOpName (OpDecl (doc,opId,_,idrng,linear,opSort,exists0,pars,prng,mbteff,tres)) = show (unqualify opId) hndCon = UserCon (toConstructorName hndName) [] [(Public,fld) | fld <- opFields] Nothing krng grng vis "" - hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] grng vis sort (DataDefNormal True) False ("// handlers for the " ++ docEffect) + hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] grng vis sort DataDefNormal False ("// handlers for the " ++ docEffect) -- declare the handle function diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index d3dfdbc6d..87c76be6e 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -26,6 +26,8 @@ value type pair { Pair(x:a, y:b) } type triple { Triple(p:pair,z:c) } +value struct vtriple(p:pair,z:c) + // single type single { Single( x:int, y:a, z:bool ) } From 5ed8c74f6f74fc0a88d435a6c54004e0ae83816f Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Thu, 23 Feb 2023 19:29:07 -0800 Subject: [PATCH 145/233] fix underscores and start digits in paths --- src/Common/Name.hs | 10 +++++++--- src/Compiler/Compile.hs | 10 +++++++--- src/Kind/InferMonad.hs | 7 +++++-- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 1f8ba4702..7be558699 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -53,7 +53,7 @@ import Lib.Trace( trace ) import Lib.PPrint (Pretty(pretty), text ) import Data.Char(isUpper,toLower,toUpper,isAlphaNum,isDigit,isAlpha) import Common.Failure(failure) -import Common.File( joinPaths, splitOn, endsWith, startsWith ) +import Common.File( joinPaths, splitOn, endsWith, startsWith, isPathSep ) import Common.Range( rangeStart, posLine, posColumn ) import Data.List(intersperse) @@ -141,7 +141,7 @@ instance Show Name where pre = if null m then "" else m ++ "/" in pre ++ case mid of (c:cs) -- | any (\c -> c `elem` ".([])") mid -> "(" ++ n ++ ")" - | not (isAlpha c || c=='_' || c=='(' || c== '.') -> "(" ++ n ++ ")" + | not (isAlphaNum c || c=='_' || c=='(' || c== '.') -> "(" ++ n ++ ")" _ -> n @@ -525,9 +525,13 @@ moduleNameToPath :: Name -> FilePath moduleNameToPath name = asciiEncode True (show name) + pathToModuleName :: FilePath -> Name pathToModuleName path - = newName $ dropWhile (\c -> c `elem` "_./") $ decode path + = newName $ dropWhile (\c -> c `elem` "_./") $ + decode $ + map (\c -> if isPathSep c then '/' else c) $ + path where -- TODO: do proper decoding decode s diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index ee1ee3ffe..314fdad6f 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -349,15 +349,19 @@ compileProgramFromFile term flags modules compileTarget rootPath stem exist <- liftIO $ doesFileExist fname if (exist) then return () else liftError $ errorMsg (errorFileNotFound flags fname) program <- lift $ parseProgramFromFile (semiInsert flags) fname - let isSuffix = map (\c -> if isPathSep c then '/' else c) (noexts stem) - `endsWith` show (programName program) + let isSuffix = -- asciiEncode True (noexts stem) `endsWith` asciiEncode True (show (programName program)) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + show (pathToModuleName (noexts stem)) `endsWith` show (programName program) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + -- `endsWith` moduleNameToPath (programName program) ppcolor c doc = color (c (colors (prettyEnvFromFlags flags))) doc if (isExecutable compileTarget || isSuffix) then return () else liftError $ errorMsg (ErrorGeneral (programNameRange program) (text "module name" <+> ppcolor colorModule (pretty (programName program)) <+> text "is not a suffix of the file path" <+> - parens (ppcolor colorSource $ text $ dquote $ stem))) + parens (ppcolor colorSource $ text $ dquote $ stem) + )) let stemName = nameFromFile stem compileProgram' term flags modules compileTarget fname program{ programName = stemName } diff --git a/src/Kind/InferMonad.hs b/src/Kind/InferMonad.hs index 589cec485..604ddb29f 100644 --- a/src/Kind/InferMonad.hs +++ b/src/Kind/InferMonad.hs @@ -250,7 +250,9 @@ infQualifiedName name range Right (name',alias) -> if (not (nameCaseEqual (qualifier name) alias)) then do let cs = cscheme env - addError range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias)) + addError range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) + -- <+> text (showPlain name ++ ", " ++ showPlain alias) + ) return name' else return name' Left [] @@ -290,10 +292,11 @@ findInfKind name0 range addError range (text "type" <+> (ppType cs (unqualify name0)) <+> text "should be cased as" <+> ppType cs (unqualify name')) else return () case mbAlias of - Just alias | nameModule name0 /= show alias + Just alias | nameModule name0 /= showPlain alias -> do let cs = cscheme env addError range (text "module" <+> color (colorModule cs) (text (nameModule name0)) <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) -- <+> text (show (name,qname,mbAlias,name0)) + -- <+> text ( nameModule name0 ++ ", " ++ showPlain alias) ) _ -> return () return (qname,KICon kind) From 4311014903a6a1e8a2c5ec26c4905a4463d643a2 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 27 Feb 2023 19:00:53 -0800 Subject: [PATCH 146/233] fix DataSize calculation --- src/Backend/C/ParcReuse.hs | 40 ++++++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 06b47508e..f0b1ac95c 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -11,7 +11,11 @@ -- constructor reuse analysis ----------------------------------------------------------------------------- +<<<<<<< Updated upstream module Backend.C.ParcReuse ( parcReuseCore ) where +======= +module Backend.C.ParcReuse ( parcReuseCore, getFixedDataAllocSize ) where +>>>>>>> Stashed changes import Lib.Trace (trace) import Control.Monad @@ -111,7 +115,7 @@ ruLam :: [TName] -> Effect -> Expr -> Reuse Expr ruLam pars eff body = fmap (Lam pars eff) $ withNone $ do forM_ pars $ \p -> do - msize <- getRuFixedDataSize (typeOf p) + msize <- getRuFixedDataAllocSize (typeOf p) case msize of Just (size, scan) -> addDeconstructed (p, Nothing, size, scan) Nothing -> return () @@ -243,7 +247,7 @@ ruPattern varName pat@PatCon{patConName,patConPatterns,patConRepr,patTypeArgs,pa return ((varName, Just pat, size, scan):reuses) else return reuses ruPattern varName _ - = do msize <- getRuFixedDataSize (typeOf varName) + = do msize <- getRuFixedDataAllocSize (typeOf varName) case msize of Just (size, scan) -> return [(varName, Nothing, size, scan)] Nothing -> return [] @@ -578,26 +582,54 @@ ruTrace msg -- | If all constructors of a type have the same shape, -- return the byte size and number of scan fields. -getRuFixedDataSize :: Type -> Reuse (Maybe (Int, Int)) -getRuFixedDataSize dataType +getRuFixedDataAllocSize :: Type -> Reuse (Maybe (Int, Int)) +getRuFixedDataAllocSize dataType = do newtypes <- getNewtypes platform <- getPlatform +<<<<<<< Updated upstream let mdataName = extractDataName dataType if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName then return Nothing else do let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName +======= + pure $ getFixedDataAllocSize platform newtypes dataType + +-- | If all constructors of a type have the same shape, +-- return the byte size and number of scan fields. +getFixedDataAllocSize :: Platform -> Newtypes -> Type -> Maybe (Int, Int) +getFixedDataAllocSize platform newtypes dataType + = let mdataName = extractDataName dataType in + if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName + then Nothing else + let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName in +>>>>>>> Stashed changes case mdataInfo of Just dataInfo -> let ddef = dataInfoDef dataInfo + in if dataDefIsValue ddef + then Nothing + else let cis = dataInfoConstrs dataInfo + sizeScanCounts = map (valueReprSizeScan platform . conInfoValueRepr) cis + in case sizeScanCounts of + (ss:sss) | all (==ss) sss -> Just ss + _ -> Nothing + {- in case ddef of DataDefValue vrepr -> let cis = dataInfoConstrs dataInfo sizes = map (conInfoSize platform) cis in case sizes of +<<<<<<< Updated upstream (s:ss) | all (==s) ss -> return $ Just (valueReprSize platform vrepr, valueReprScanCount vrepr) _ -> return Nothing _ -> return Nothing _ -> return Nothing +======= + (s:ss) | all (==s) ss -> Just (valueReprSize platform vrepr, valueReprScanCount vrepr) + _ -> Nothing + _ -> Nothing -} + _ -> Nothing +>>>>>>> Stashed changes where extractDataName :: Type -> Maybe Name extractDataName tp From ecbb490dfbd63460897c98166618261e8dbc17dc Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 27 Feb 2023 19:01:26 -0800 Subject: [PATCH 147/233] merge --- src/Backend/C/ParcReuse.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index f0b1ac95c..46bf7a4e9 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -586,12 +586,6 @@ getRuFixedDataAllocSize :: Type -> Reuse (Maybe (Int, Int)) getRuFixedDataAllocSize dataType = do newtypes <- getNewtypes platform <- getPlatform -<<<<<<< Updated upstream - let mdataName = extractDataName dataType - if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName - then return Nothing else do - let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName -======= pure $ getFixedDataAllocSize platform newtypes dataType -- | If all constructors of a type have the same shape, @@ -602,7 +596,6 @@ getFixedDataAllocSize platform newtypes dataType if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName then Nothing else let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName in ->>>>>>> Stashed changes case mdataInfo of Just dataInfo -> let ddef = dataInfoDef dataInfo @@ -619,17 +612,10 @@ getFixedDataAllocSize platform newtypes dataType -> let cis = dataInfoConstrs dataInfo sizes = map (conInfoSize platform) cis in case sizes of -<<<<<<< Updated upstream - (s:ss) | all (==s) ss -> return $ Just (valueReprSize platform vrepr, valueReprScanCount vrepr) - _ -> return Nothing - _ -> return Nothing - _ -> return Nothing -======= (s:ss) | all (==s) ss -> Just (valueReprSize platform vrepr, valueReprScanCount vrepr) _ -> Nothing _ -> Nothing -} _ -> Nothing ->>>>>>> Stashed changes where extractDataName :: Type -> Maybe Name extractDataName tp From 9b298846ca0b2432d2895a0a19f0fe9c70d41df0 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 27 Feb 2023 19:02:30 -0800 Subject: [PATCH 148/233] merge --- src/Backend/C/ParcReuse.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 46bf7a4e9..4dbae5f3c 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -11,11 +11,7 @@ -- constructor reuse analysis ----------------------------------------------------------------------------- -<<<<<<< Updated upstream -module Backend.C.ParcReuse ( parcReuseCore ) where -======= module Backend.C.ParcReuse ( parcReuseCore, getFixedDataAllocSize ) where ->>>>>>> Stashed changes import Lib.Trace (trace) import Control.Monad From 0bfd759306268e447de07d201467f2d73ed53240 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 27 Feb 2023 19:12:15 -0800 Subject: [PATCH 149/233] allow reference enumerations --- src/Backend/C/FromCore.hs | 4 +++- src/Kind/Repr.hs | 4 ++-- test/cgen/data1.kk | 13 ++++++++++--- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index b5e15c9ba..0311a0007 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -447,7 +447,8 @@ genTypeDefPre (Data info isExtend) then let enumIntTp = case (dataInfoDef info) of DataDefValue (ValueRepr 1 0 _) -> "uint8_t" DataDefValue (ValueRepr 2 0 _) -> "uint16_t" - _ -> "uint32_t" + DataDefValue (ValueRepr 4 0 _) -> "uint32_t" + _ -> "uint64_t" ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> @@ -952,6 +953,7 @@ genDupDropX isDup name info dataRepr conInfos ret = (if isDup then [text "return _x;"] else []) dupDropTests | dataRepr == DataEnum = ret + | all (\(_,conRepr,_,_) -> isConSingleton conRepr) conInfos = ret -- for ref type enumerations | dataRepr == DataIso = [genDupDropIso isDup (head conInfos)] ++ ret -- | dataRepr == DataStructAsMaybe = [genDupDropMaybe isDup conInfos] ++ ret | dataRepr <= DataStruct = genDupDropMatch (map (genDupDropTests isDup dataRepr) conInfos) ++ ret diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 50542298a..273c8fbec 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -53,8 +53,8 @@ createDataDef emitError emitWarning lookupDataInfo DataDefNormal -> do dd <- createMaxDataDef conInfos case dd of - DataDefValue vr | isEnum - -> return dd + {- DataDefValue vr | isEnum -- allow allocated enum types + -> return dd -} DataDefValue vr | isIso -- iso types are always value types -> return dd _ -> return DataDefNormal diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index 87c76be6e..2ffd0e30d 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -13,13 +13,20 @@ type void // enum -type unit { Unit() } +type unit + Unit // enum -type bool { False; True } +type bool + False + True // iso -type iso { Iso(x:int) } +type iso + Iso(x:int) + +ref type any + Any // single struct value type pair { Pair(x:a, y:b) } From c2e70162a22ce588f1ba272d8c6fe748b72c0efa Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 2 Mar 2023 15:52:03 -0800 Subject: [PATCH 150/233] update vscode syntax for fip/fbip --- .../vscode/koka.language-koka/syntaxes/koka.json | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/support/vscode/koka.language-koka/syntaxes/koka.json b/support/vscode/koka.language-koka/syntaxes/koka.json index 52e586a0c..327c8611e 100644 --- a/support/vscode/koka.language-koka/syntaxes/koka.json +++ b/support/vscode/koka.language-koka/syntaxes/koka.json @@ -423,7 +423,7 @@ }, "decl_function": - { "match": "((?:inline|noinline)?\\s*(?:fun|fn|ctl|ret))\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")" + { "match": "((?:(?:inline|noinline)\\s+)?(?:tail\\s+)?(?:(?:fip|fbip)(?:\\(\\d+\\))?\\s+)?(?:fun|fn|ctl|ret))\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")" , "captures": { "1": { "name": "keyword.declaration.function koka.keyword.fun" }, "2": { "name": "entity.name.function koka.id.decl.function" } @@ -444,7 +444,7 @@ }, "decl_external": - { "match": "((?:inline|noinline)?\\s*extern)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")?" + { "match": "((?:(?:inline|noinline)\\s+)?(?:(?:fip|fbip)\\s+)?extern)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")?" , "captures": { "1": { "name": "keyword.declaration.function koka.keyword.extern" }, "2": { "name": "entity.name.function koka.id.decl.function" } @@ -452,7 +452,7 @@ }, "decl_val": - { "match": "((?:inline|noinline)?\\s*val)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\))?" + { "match": "((?:(?:inline|noinline)\\s+)?val)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\))?" , "captures": { "1": { "name": "keyword.declaration koka.keyword.val" }, "2": { "name": "entity.name koka.id.decl.val" } @@ -474,7 +474,7 @@ "top_type": { "begin": "(:(?![$%&\\*\\+@!\\\\\\^~=\\.:\\-\\|<>]))|(where|iff|when)(?![\\w\\-])" - , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|value|ref|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|fip|fbip|tail|value|ref|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "constant.numeric.type support.type koka.type" }, "2" : { "name": "keyword koka.keyword.$2" } } , "endCaptures": { "0" : { "name": "invalid.keyword koka.invalid" }} @@ -486,7 +486,7 @@ "top_type_type": { "begin": "((?:(?:value|ref|open|extend|rec|co)?\\s*type)|(?:named\\s+)?(?:scoped\\s+)?(?:linear\\s+)?(?:rec\\s+)?(?:effect|context|ambient))\\s+(?!fn|fun|val|raw|final|ctl|ret)([a-z][\\w\\-]+|<>|<\\|>|\\(,*\\))" - , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|ref|open|extend|inline|noinline)(?![\\w\\-?']))" + , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|ref|open|extend)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration.type koka.keyword" } , "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }} , "endCaptures": { "0": { "name": "punctuation.separator koka.special" }} @@ -497,7 +497,7 @@ "top_type_alias": { "begin": "(alias)\\s+([a-z][\\w\\-]+)" - , "end": "(?=[,\\)\\{\\}\\[\\];\"`A-Z]|(infix|infixr|infixl|inline|noinline|type|co|rec|linear|alias|effect|context|ambient|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(?=[,\\)\\{\\}\\[\\];\"`A-Z]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|linear|alias|effect|context|ambient|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration koka.keyword" } , "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }} , "endCaptures": { "0": { "name": "invalid.keyword koka.keyword.invalid" }} @@ -520,7 +520,7 @@ "top_type_struct_args": { "begin": "((?:(?:value|ref)\\s*)?struct)\\s+([a-z][\\w\\-]*|\\(,*\\))\\s*(<)" - , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration koka.keyword.struct" }, "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }, "3" : { "name": "constant.numeric.type support.type koka.type.special" }} @@ -533,7 +533,7 @@ "top_type_quantifier": { "begin": "(exists|forall|some)(\\s*)(<)" - , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword koka.keyword" }, "3" : { "name": "constant.numeric.type support.type koka.type.special" }} , "endCaptures": { "1": {"name": "constant.numeric.type support.type koka.type.special" }, From 981a0a64c15bccdd474f98541b2d0fa0c6effe34 Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 2 Mar 2023 16:33:47 -0800 Subject: [PATCH 151/233] add fip/fbip keywords --- src/Common/Syntax.hs | 10 +++++ src/Compiler/Compile.hs | 4 +- src/Kind/Infer.hs | 14 +++---- src/Static/BindingGroups.hs | 6 +-- src/Static/FixityResolve.hs | 6 +-- src/Syntax/Parse.hs | 79 ++++++++++++++++++++++++------------- src/Syntax/Syntax.hs | 13 +++--- src/Type/Infer.hs | 6 +-- 8 files changed, 88 insertions(+), 50 deletions(-) diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 9a502c928..3e1126552 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -16,6 +16,7 @@ module Common.Syntax( Visibility(..) , DefSort(..), isDefFun, defFun , ParamInfo(..) , DefInline(..) + , Fip(..) , Target(..), CTarget(..), JsTarget(..), isTargetC, isTargetJS, isTargetWasm , isPublic, isPrivate , DataDef(..) @@ -313,3 +314,12 @@ data Assoc = AssocNone | AssocRight | AssocLeft deriving (Eq,Show) + + +{-------------------------------------------------------------------------- + Fip +--------------------------------------------------------------------------} +data Fip = Fip Int + | Fbip Int + | Nofip + deriving (Eq,Ord,Show) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index bdc3d3862..3e29c7197 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -216,7 +216,7 @@ compileExpression term flags loaded compileTarget program line input [(qnameShow,_)] -> do let expression = mkApp (Var (qualify nameSystemCore (newName "println")) False r) [mkApp (Var qnameShow False r) [mkApp (Var qnameExpr False r) []]] - let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (DefFun []) InlineNever "" + let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (DefFun []) InlineNever False Nofip "" let programDef' = programAddDefs programDef [] [defMain] compileProgram' term flags (loadedModules ld) (Executable nameMain ()) "" programDef' return ld @@ -455,7 +455,7 @@ compileProgram' term flags modules compileTarget fname program expression = App (Var (if (isHiddenName mainName) then mainName -- .expr else unqualify mainName -- main ) False r) [] r - defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (DefFun []) InlineNever "" + defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (DefFun []) InlineNever False Nofip "" program2 = programAddDefs program [] [defMain] in do (loaded3,_) <- typeCheck loaded1 flags 0 coreImports program2 return (Executable mainName2 tp, loaded3) -- TODO: refine the type of main2 diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 0954bc48c..07ed77a06 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -191,7 +191,7 @@ synCopyCon modName info con params = [ValueBinder name Nothing (if not (hasAccessor name t con) then Nothing else (Just (app (var name) [var argName]))) rc rc| (name,t) <- conInfoParams con] expr = Lam ([ValueBinder argName Nothing Nothing rc rc] ++ params) body rc body = app (var (conInfoName con)) [var name | (name,tp) <- conInfoParams con] - def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (DefFun []) InlineAuto "") + def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (DefFun []) InlineAuto False (Fip 0) "") in def hasAccessor :: Name -> Type -> ConInfo -> Bool @@ -251,7 +251,7 @@ synAccessors modName info messages = [Lit (LitString (sourceName (posSource (rangeStart rng)) ++ show rng) rng), Lit (LitString (show name) rng)] doc = "// Automatically generated. Retrieves the `" ++ show name ++ "` constructor field of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (DefFun [Borrow]) InlineAlways doc) + in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (DefFun [Borrow]) InlineAlways False (Fip 0) doc) in map synAccessor fields @@ -269,14 +269,14 @@ synTester info con branch2 = Branch (PatWild rc) [Guard guardTrue (Var nameFalse False rc)] patterns = [(Nothing,PatWild rc) | _ <- conInfoParams con] doc = "// Automatically generated. Tests for the `" ++ nameId (conInfoName con) ++ "` constructor of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (DefFun [Borrow]) InlineAlways doc)] + in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (DefFun [Borrow]) InlineAlways False (Fip 0) doc)] synConstrTag :: (ConInfo) -> DefGroup Type synConstrTag (con) = let name = toOpenTagName (unqualify (conInfoName con)) rc = conInfoRange con expr = Lit (LitString (show (conInfoName con)) rc) - in DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) DefVal InlineNever "") + in DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) DefVal InlineNever False Nofip "") {--------------------------------------------------------------- Types for constructors @@ -398,7 +398,7 @@ infExternals externals return (ext:exts) infExternal :: [Name] -> External -> KInfer (Core.External,[Name]) -infExternal names (External name tp pinfos nameRng rng calls vis doc) +infExternal names (External name tp pinfos nameRng rng calls vis fip doc) = do tp' <- infResolveType tp (Check "Externals must be values" rng) qname <- qualifyDef name let cname = let n = length (filter (==qname) names) in @@ -501,9 +501,9 @@ infDefGroup (DefNonRec def) return (DefNonRec def') infDef :: (Def UserType) -> KInfer (Def Type) -infDef (Def binder rng vis isVal inl doc) +infDef (Def binder rng vis isVal inl isTail fip doc) = do binder' <- infValueBinder binder - return (Def binder' rng vis isVal inl doc) + return (Def binder' rng vis isVal inl isTail fip doc) infValueBinder (ValueBinder name () expr nameRng rng) = do expr' <- infExpr expr diff --git a/src/Static/BindingGroups.hs b/src/Static/BindingGroups.hs index e6fc31765..4e2652ddf 100644 --- a/src/Static/BindingGroups.hs +++ b/src/Static/BindingGroups.hs @@ -113,10 +113,10 @@ dependencies modName defs (depDefs, deps) = unzipWith (id,unions) (map (dependencyDef modName) defs) dependencyDef :: Name -> UserDef -> (UserDef, Deps) -dependencyDef modName (Def binding range vis isVal inline defDoc) - = (Def depBinding range vis isVal inline defDoc, deps) +dependencyDef modName def + = (def{ defBinder = depBinding}, deps) where - (depBinding,deps) = dependencyBinding modName binding + (depBinding,deps) = dependencyBinding modName (defBinder def) dependencyBinding :: Name -> UserValueBinder UserExpr -> (UserValueBinder UserExpr, Deps) dependencyBinding modName vb diff --git a/src/Static/FixityResolve.hs b/src/Static/FixityResolve.hs index 5ed163535..e55a6e6f2 100644 --- a/src/Static/FixityResolve.hs +++ b/src/Static/FixityResolve.hs @@ -58,9 +58,9 @@ resolveDefGroup (DefRec defs) resolveDefGroup (DefNonRec def) = resolveDef def >>= return . DefNonRec -resolveDef (Def binder range vis isVal inline doc) - = do binder' <- resolveBinder binder - return (Def binder' range vis isVal inline doc) +resolveDef def + = do binder' <- resolveBinder (defBinder def) + return def{ defBinder = binder'} resolveBinder binder = do expr' <- resolveExpr (binderExpr binder) diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index c0f8f9756..c29ad25ae 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -170,7 +170,7 @@ expression name = interactive $ do e <- aexpr let r = getRange e - return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun []) InlineNever "" + return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun []) InlineNever False Nofip "" -- ,Def (ValueBinder (prepend ".eval" name) () (Lam [] (App (Var nameGPrint False r) [Var name False r] r))) ) @@ -323,12 +323,13 @@ externDecl dvis <|> try ( do (vis,vrng) <- visibility dvis inline <- parseInline + fip <- parseFip (krng,doc) <- dockeyword "extern" - return (Right (combineRange vrng krng, vis, doc, inline))) + return (Right (combineRange vrng krng, vis, doc, inline, fip))) case lr of Left p -> do extern <- p return [DefExtern extern] - Right (krng,vis,doc,inline) + Right (krng,vis,doc,inline,fip) -> do (name,nameRng) <- funid (pars,pinfos,args,tp,annotate) <- do keyword ":" @@ -346,13 +347,13 @@ externDecl dvis return (map lift pars,pinfos,genArgs pars,tp,\body -> promote [] tpars [] (Just (Just teff, tres)) body) (exprs,rng) <- externalBody if (inline == InlineAlways) - then return [DefExtern (External name tp pinfos nameRng (combineRanges [krng,rng]) exprs vis doc)] + then return [DefExtern (External name tp pinfos nameRng (combineRanges [krng,rng]) exprs vis fip doc)] else do let externName = newHiddenExternalName name fullRng = combineRanges [krng,rng] - extern = External externName tp pinfos (before nameRng) (before fullRng) exprs Private doc + extern = External externName tp pinfos (before nameRng) (before fullRng) exprs Private fip doc body = annotate (Lam pars (App (Var externName False rangeNull) args fullRng) fullRng) binder = ValueBinder name () body nameRng fullRng - extfun = Def binder fullRng vis (defFun pinfos) InlineNever doc + extfun = Def binder fullRng vis (defFun pinfos) InlineNever False fip doc return [DefExtern extern, DefValue extfun] where typeFromPars :: Range -> [ValueBinder UserType (Maybe UserExpr)] -> UserType -> UserType -> UserType @@ -647,7 +648,7 @@ makeUserCon con foralls resTp exists pars nameRng rng vis doc = [(vis,par{ binderExpr = Nothing }) | (vis,par) <- pars] creator = let name = newCreatorName con - def = Def binder rng vis (defFun []) InlineAlways doc + def = Def binder rng vis (defFun []) InlineAlways True Nofip doc binder = ValueBinder name () body nameRng nameRng body = Ann (Lam lparams (App (Var con False nameRng) arguments rng) rng) tpFull rng params = [par{ binderType = (if (isJust (binderExpr par)) then makeOptional (binderType par) else binderType par) } | (_,par) <- pars] @@ -706,7 +707,7 @@ bindExprToVal opname oprange expr = let fresh = makeFreshHiddenName "value" opname oprange freshVar = (Var fresh False oprange) erange = (getRange expr) - binder = (Def (ValueBinder fresh () expr oprange erange) oprange Private DefVal InlineAuto "") + binder = (Def (ValueBinder fresh () expr oprange erange) oprange Private DefVal InlineAuto False Nofip "") in (\body -> Bind binder body erange, \params -> freshVar {- \params -> resumeCall freshVar params erange -}) @@ -849,7 +850,7 @@ makeEffectDecl decl = (quantify QForall tpars (makeTpApp (TpCon nameTpHTag krng) [makeTpApp (TpCon hndName krng) (map tpVar tparsNonScoped) krng] krng)) krng) - krng krng) krng vis DefVal InlineNever ("// runtime tag for the " ++ docEffect) + krng krng) krng vis DefVal InlineNever True Nofip ("// runtime tag for the " ++ docEffect) --extendConName = toEffectConName (tbinderName ename) @@ -906,7 +907,7 @@ makeEffectDecl decl = (Nothing, Var (newName "ret") False krng), (Nothing, wrapAction (Var (newName "action") False krng))] handleDef = Def (ValueBinder handleName () handleBody irng rng) - grng vis (defFun []) InlineNever ("// handler for the " ++ docEffect) + grng vis (defFun []) InlineNever True Nofip ("// handler for the " ++ docEffect) in [DefType effTpDecl, DefValue tagDef, DefType hndTpDecl, DefValue handleDef] ++ map DefValue opSelects @@ -1070,7 +1071,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa -- create an operation selector explicitly so we can hide the handler constructor selectId = toOpSelectorName id - opSelect = let def = Def binder krng vis (defFun [Borrow]) InlineAlways ("// select `" ++ show id ++ "` operation out of the " ++ docEffect ++ " handler") + opSelect = let def = Def binder krng vis (defFun [Borrow]) InlineAlways True Nofip ("// select `" ++ show id ++ "` operation out of the " ++ docEffect ++ " handler") nameRng = krng binder = ValueBinder selectId () body nameRng nameRng body = Ann (Lam [hndParam] innerBody grng) fullTp grng @@ -1093,7 +1094,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa -- create a typed perform wrapper: fun op(x1:a1,..,xN:aN) : b { performN(evv-at(0),clause-op,x1,..,xN) } - opDef = let def = Def binder idrng vis (DefFun []) InlineAlways ("// call `" ++ show id ++ "` operation of the " ++ docEffect) + opDef = let def = Def binder idrng vis (DefFun []) InlineAlways True Nofip ("// call `" ++ show id ++ "` operation of the " ++ docEffect) nameRng = idrng binder = ValueBinder id () body nameRng nameRng body = Ann (Lam lparams innerBody rng) tpFull rng @@ -1138,7 +1139,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa phantom = App (Var namePhantom False krng) [] krng annot = Ann phantom qualTpe krng in Just $ Def (ValueBinder opName () annot idrng krng) - krng vis DefVal InlineNever "// phantom definition for value operations" + krng vis DefVal InlineNever True Nofip "// phantom definition for value operations" else Nothing @@ -1152,39 +1153,63 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa pureDecl :: Visibility -> LexParser UserDef pureDecl dvis - = do (vis,vrng,rng,doc,inline,isVal) + = do pdecl <- try $ do (vis,vrng) <- visibility dvis inline <- parseInline - (do (rng,doc) <- dockeywordFun; return (vis,vrng,rng,doc,inline,False) + (do (rng,doc) <- dockeyword "val" -- return (vis,vrng,rng,doc,inline,True) + return (valDecl (combineRange vrng rng) doc vis inline) <|> - do (rng,doc) <- dockeyword "val"; return (vis,vrng,rng,doc,inline,True) + do isTail <- parseTail + fip <- parseFip + (rng,doc) <- dockeywordFun -- return (vis,vrng,rng,doc,inline,False) + return (funDecl (combineRange vrng rng) doc vis inline isTail fip) <|> do keyword "fn" fail "hint: use 'fun' to start a named function definition (and 'fn' for anonymous functions)") - (if isVal then valDecl else funDecl) (combineRange vrng rng) doc vis inline + -- (if isVal then valDecl else funDecl) (combineRange vrng rng) doc vis inline -- valueDecl vrng vis <|> functionDecl vrng vis + pdecl + +parseTail :: LexParser Bool +parseTail + = do specialId "tail" + return True + <|> return False + +parseFip :: LexParser Fip +parseFip + = do specialId "fip" + (n,_) <- parens integer <|> return (0,rangeNull) + return (Fip (fromInteger n)) + <|> do specialId "fbip" + (n,_) <- parens integer <|> return (0,rangeNull) + return (Fbip (fromInteger n)) + <|> return Nofip + functionDecl vrng vis - = do (rng,doc,inline) <- try $ do inline <- parseInline - (rng,doc) <- dockeywordFun - return (rng,doc,inline) - funDecl (combineRange vrng rng) doc vis inline + = do pdecl <- try $ do inline <- parseInline + isTail <- parseTail + fip <- parseFip + (rng,doc) <- dockeywordFun + return (funDecl (combineRange vrng rng) doc vis inline isTail fip) + pdecl varDecl = do (vrng,doc) <- dockeyword "var" bind <- binder vrng keyword ":=" body <- blockexpr - return (Def (bind body) (combineRanged vrng body) Private DefVar InlineNever doc) + return (Def (bind body) (combineRanged vrng body) Private DefVar InlineNever True Nofip doc) valDecl rng doc vis inline = do bind <- binder rng keyword "=" body <- blockexpr - return (Def (bind body) (combineRanged rng body) vis DefVal inline doc) + return (Def (bind body) (combineRanged rng body) vis DefVal inline True Nofip doc) -funDecl rng doc vis inline +funDecl rng doc vis inline isTail fip = do spars <- squantifier -- tpars <- aquantifier -- todo: store somewhere (name,nameRng) <- funid @@ -1192,7 +1217,7 @@ funDecl rng doc vis inline body <- bodyexpr let fun = promote spars tpars preds mbtres (Lam pars body (combineRanged rng body)) - return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis (defFun pinfos) inline doc) + return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis (defFun pinfos) inline isTail fip doc) -- fundef: forall parameters, parameters, (effecttp, resulttp), annotation funDef :: Bool -> LexParser ([TypeBinder UserKind],[ValueBinder (Maybe UserType) (Maybe UserExpr)], [ParamInfo], Range, Maybe (Maybe UserType, UserType),[UserType], UserExpr -> UserExpr) @@ -1308,7 +1333,7 @@ block combine :: Statement -> UserExpr -> UserExpr combine (StatFun f) exp = f exp combine (StatExpr e) exp = let r = getRange e - in Bind (Def (ValueBinder (newName "_") () e r r) r Private DefVal InlineAuto "") exp r + in Bind (Def (ValueBinder (newName "_") () e r r) r Private DefVal InlineAuto False Nofip "") exp r combine (StatVar def) exp = let (ValueBinder name () expr nameRng rng) = defBinder def in App (Var nameLocal False rng) -- put parens over the lambda so it comes later during type inference (so the type of expr can be propagated in) @@ -1368,7 +1393,7 @@ localValueDecl Just tp -> Ann e (promoteType tp) rng Nothing -> e vbinder = ValueBinder (binderName binder) () annexpr (binderNameRange binder) (binderRange binder) - in \body -> Bind (Def vbinder rng Private DefVal InlineAuto "") body (combineRanged krng body) + in \body -> Bind (Def vbinder rng Private DefVal InlineAuto False Nofip "") body (combineRanged krng body) case unParens(pat) of PatVar (binder@ValueBinder{ binderExpr = PatWild _ }) -> return $ bindVar binder (binderType binder) (binderRange binder) diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index 6b5e16287..6344e05e7 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -67,6 +67,7 @@ data External , extRange :: Range , extInline :: [(Target,ExternalCall)] -- map: target inline , extVis :: Visibility + , extFip :: Fip , extDoc :: String } | ExternalImport{ extImport :: [(Target,[(String,String)])] @@ -196,6 +197,8 @@ data Def t , defVis :: Visibility , defSort :: DefSort , defInline :: DefInline + , defTail :: Bool + , defFip :: Fip , defDoc :: String } deriving (Show) @@ -325,8 +328,8 @@ instance Ranged (TypeDef t u k) where = typeDefRange typeDef instance Ranged t => Ranged (Def t) where - getRange (Def binder nameTypeRange _ _ _ _) - = getRange binder + getRange def + = getRange (defBinder def) instance Ranged (ValueBinder t e) where getRange vb = binderRange vb @@ -443,7 +446,7 @@ instance HasName (ValueBinder t e) where getRName vb = (binderName vb,binderNameRange vb) instance HasName (Def t) where - getRName (Def vb range _ _ _ _) = getRName vb + getRName def = getRName (defBinder def) @@ -482,10 +485,10 @@ instance HasFreeTypeVar a => HasFreeTypeVar (Either a b) where Access definitions --------------------------------------------------------------------------} defBody :: Def t -> Expr t -defBody (Def vb _ _ _ _ _) = binderExpr vb +defBody def = binderExpr (defBinder def) defName :: Def t -> Name -defName (Def vb _ _ _ _ _) = binderName vb +defName def = binderName (defBinder def) defType :: Def t -> Maybe t defType def diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index eb0bb4db2..e68a1c284 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -206,7 +206,7 @@ inferDefGroup topLevel (DefRec defs) cont createGammas :: [(Name,NameInfo)] -> [(Name,NameInfo)] -> [Def Type] -> Inf ([(Name,NameInfo)],[(Name,NameInfo)]) createGammas gamma infgamma [] = return (reverse gamma, reverse infgamma) - createGammas gamma infgamma (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc : defs) + createGammas gamma infgamma (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl tail fip doc : defs) = case (lookup name infgamma) of (Just _) -> do env <- getPrettyEnv @@ -439,7 +439,7 @@ inferRecDef topLevel infgamma def inferDef :: Expect -> Def Type -> Inf Core.Def -inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl doc) +inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl tail fip doc) =do penv <- getPrettyEnv if (verbose penv >= 3) then Lib.Trace.trace ("infer: " ++ show sort ++ " " ++ show name) $ return () @@ -459,7 +459,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl subst (Core.Def name resTp resCore vis sort inl nameRng doc) -- must 'subst' since the total unification can cause substitution. (see test/type/hr1a) inferBindDef :: Def Type -> Inf (Effect,Core.Def) -inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc) +inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl tail fip doc) = -- trace ("infer bind def: " ++ show name ++ ", var?:" ++ show (sort==DefVar)) $ do withDefName name $ do (tp,eff,coreExpr) <- inferExpr Nothing Instantiated expr From df0101daf90ae71a9a7c2a83a08d070879cb64a9 Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 2 Mar 2023 21:12:40 -0800 Subject: [PATCH 152/233] propagate fip information through all definitions --- src/Backend/C/Parc.hs | 4 +-- src/Common/Syntax.hs | 70 +++++++++++++++++++++++++++++++++++------ src/Compiler/Compile.hs | 4 +-- src/Core/Borrowed.hs | 2 +- src/Core/CheckFBIP.hs | 51 +++++++++++++++++++++--------- src/Core/Core.hs | 8 ++--- src/Core/FunLift.hs | 2 +- src/Core/GenDoc.hs | 2 +- src/Core/MonadicLift.hs | 2 +- src/Core/Parse.hs | 14 +++++---- src/Core/Pretty.hs | 8 ++--- src/Core/UnReturn.hs | 2 +- src/Kind/Infer.hs | 12 +++---- src/Syntax/Parse.hs | 69 +++++++++++++++++++--------------------- src/Syntax/Syntax.hs | 2 -- src/Type/Assumption.hs | 4 +-- src/Type/Infer.hs | 8 ++--- 17 files changed, 167 insertions(+), 97 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index a4a18f2f9..8bb8bc6ed 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -87,10 +87,10 @@ parcDef topLevel def -------------------------------------------------------------------------- parcTopLevelExpr :: DefSort -> Expr -> Parc Expr -parcTopLevelExpr (DefFun bs) expr +parcTopLevelExpr ds@(DefFun bs _) expr = case expr of TypeLam tpars body - -> TypeLam tpars <$> parcTopLevelExpr (DefFun bs) body + -> TypeLam tpars <$> parcTopLevelExpr ds body Lam pars eff body -> do let parsBs = zip pars $ bs ++ repeat Own let parsSet = S.fromList $ map fst $ filter (\x -> snd x == Own) parsBs diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 3e1126552..d5d4e466b 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -13,10 +13,10 @@ module Common.Syntax( Visibility(..) , Assoc(..) , Fixity(..) , DataKind(..) - , DefSort(..), isDefFun, defFun + , DefSort(..), isDefFun, defFun, defFunEx, defSortShowFull , ParamInfo(..) , DefInline(..) - , Fip(..) + , Fip(..), fipIsTail, fipAlloc, noFip, isNoFip , Target(..), CTarget(..), JsTarget(..), isTargetC, isTargetJS, isTargetWasm , isPublic, isPrivate , DataDef(..) @@ -268,7 +268,10 @@ valueReprScan n = ValueRepr 0 n 0 --------------------------------------------------------------------------} data DefSort - = DefFun [ParamInfo] | DefVal | DefVar + = DefFun { defFunParamInfos :: [ParamInfo], + defFunFip :: Fip } + | DefVal + | DefVar deriving Eq data ParamInfo @@ -276,15 +279,26 @@ data ParamInfo | Own deriving(Eq,Show) -isDefFun (DefFun _) = True +isDefFun (DefFun {}) = True isDefFun _ = False +defFunEx :: [ParamInfo] -> Fip -> DefSort +defFunEx pinfos fip = if all (==Own) pinfos then DefFun [] fip else DefFun pinfos fip + defFun :: [ParamInfo] -> DefSort -defFun pinfos = if all (==Own) pinfos then DefFun [] else DefFun pinfos +defFun pinfos = defFunEx pinfos noFip + +defSortShowFull :: DefSort -> String +defSortShowFull ds + = case ds of + DefFun pinfos fip -> show fip ++ "fun" + DefVal -> "val" + DefVar -> "var" + instance Show DefSort where show ds = case ds of - DefFun _ -> "fun" + DefFun{} -> "fun" DefVal -> "val" DefVar -> "var" @@ -319,7 +333,43 @@ data Assoc = AssocNone {-------------------------------------------------------------------------- Fip --------------------------------------------------------------------------} -data Fip = Fip Int - | Fbip Int - | Nofip - deriving (Eq,Ord,Show) +data Fip = Fip { fipAlloc_ :: Int } + | Fbip { fipAlloc_ :: Int, fipTail :: Bool } + | NoFip { fipTail :: Bool } + deriving (Eq,Ord) + +noFip :: Fip +noFip = NoFip False + +isNoFip (NoFip _) = True +isNoFip _ = False + +fipIsTail :: Fip -> Bool +fipIsTail fip + = case fip of + Fbip _ t -> t + NoFip t -> t + _ -> True + +fipAlloc :: Fip -> Int +fipAlloc fip + = case fip of + Fip n -> n + Fbip n _ -> n + NoFip _ -> 0 + + +instance Show Fip where + show fip = case fip of + Fip n -> "fip" ++ showN n + Fbip n t -> showTail t ++ "fbip" ++ showN n + NoFip t -> showTail t + where + showN 0 = " " + showN n = "(" ++ show n ++ ") " + + showTail True = "tail " + showTail _ = " " + + + diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 3e29c7197..b0204998f 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -216,7 +216,7 @@ compileExpression term flags loaded compileTarget program line input [(qnameShow,_)] -> do let expression = mkApp (Var (qualify nameSystemCore (newName "println")) False r) [mkApp (Var qnameShow False r) [mkApp (Var qnameExpr False r) []]] - let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (DefFun []) InlineNever False Nofip "" + let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (defFun []) InlineNever "" let programDef' = programAddDefs programDef [] [defMain] compileProgram' term flags (loadedModules ld) (Executable nameMain ()) "" programDef' return ld @@ -455,7 +455,7 @@ compileProgram' term flags modules compileTarget fname program expression = App (Var (if (isHiddenName mainName) then mainName -- .expr else unqualify mainName -- main ) False r) [] r - defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (DefFun []) InlineNever False Nofip "" + defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (defFun []) InlineNever "" program2 = programAddDefs program [] [defMain] in do (loaded3,_) <- typeCheck loaded1 flags 0 coreImports program2 return (Executable mainName2 tp, loaded3) -- TODO: refine the type of main2 diff --git a/src/Core/Borrowed.hs b/src/Core/Borrowed.hs index 87a8a11c6..9a9a6bd65 100644 --- a/src/Core/Borrowed.hs +++ b/src/Core/Borrowed.hs @@ -101,7 +101,7 @@ extractDefGroup (DefNonRec def) extractBorrowDef :: Bool -> Def -> Maybe BorrowDef extractBorrowDef isRec def = case defSort def of - DefFun pinfos | not (null pinfos) -> Just (defName def,pinfos) + DefFun pinfos _ | not (null pinfos) -> Just (defName def,pinfos) _ -> Nothing instance Show Borrowed where diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 4006742ca..52da9725a 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -76,24 +76,32 @@ chkDefGroup defGroup chkTopLevelDef :: [Name] -> Def -> Chk () chkTopLevelDef defGroupNames def = withCurrentDef def $ do - out <- extractOutput $ withInput (\_ -> Input S.empty [] defGroupNames True) $ - chkTopLevelExpr (defSort def) (defExpr def) - checkOutputEmpty out + case defSort def of + -- only check fip and fbip annotated functions + DefFun borrows fip | not (isNoFip fip) -> + do out <- withFip fip $ + extractOutput $ + withInput (\_ -> Input S.empty (capFromFip fip) defGroupNames True) $ + chkTopLevelExpr borrows fip (defExpr def) + checkOutputEmpty out + _ -> return () + -- | Lambdas at the top-level are part of the signature and not allocations. -chkTopLevelExpr :: DefSort -> Expr -> Chk () -chkTopLevelExpr (DefFun bs) (Lam pars eff body) +chkTopLevelExpr :: [ParamInfo] -> Fip -> Expr -> Chk () +chkTopLevelExpr borrows fip (Lam pars eff body) -- todo: track fip to adjust warnings = do chkEffect eff - let bpars = map snd $ filter ((==Borrow) . fst) $ zipDefault Own bs pars - let opars = map snd $ filter ((==Own) . fst) $ zipDefault Own bs pars + let bpars = map snd $ filter ((==Borrow) . fst) $ zipDefault Own borrows pars + let opars = map snd $ filter ((==Own) . fst) $ zipDefault Own borrows pars withBorrowed (S.fromList $ map getName bpars) $ do out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out opars -chkTopLevelExpr def (TypeLam _ body) - = chkTopLevelExpr def body -chkTopLevelExpr def (TypeApp body _) - = chkTopLevelExpr def body -chkTopLevelExpr _ expr = chkExpr expr +chkTopLevelExpr borrows fip (TypeLam _ body) + = chkTopLevelExpr borrows fip body +chkTopLevelExpr borrows fip (TypeApp body _) + = chkTopLevelExpr borrows fip body +chkTopLevelExpr borrows fip expr + = chkExpr expr chkExpr :: Expr -> Chk () chkExpr expr @@ -268,7 +276,8 @@ data Env = Env{ currentDef :: [Def], prettyEnv :: Pretty.Env, platform :: Platform, newtypes :: Newtypes, - borrowed :: Borrowed + borrowed :: Borrowed, + fip :: Fip } data Capability @@ -277,6 +286,13 @@ data Capability | HasStack -- may use non-tail recursion deriving (Eq, Ord, Bounded, Enum) +capFromFip :: Fip -> [Capability] +capFromFip fip + = case fip of + Fip n -> [] + Fbip n isTail -> [HasDealloc] ++ (if isTail then [] else [HasStack]) + NoFip isTail -> [HasDealloc,HasAlloc] ++ (if isTail then [] else [HasStack]) + data Input = Input{ delta :: S.Set Name, capabilities :: [Capability], defGroupNames :: [Name], @@ -311,7 +327,7 @@ data Result a = Ok a Output [Doc] runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Chk a -> (a,[Doc]) runChk penv u platform newtypes borrowed (Chk c) - = case c (Env [] penv platform newtypes borrowed) (Input S.empty [] [] True) of + = case c (Env [] penv platform newtypes borrowed noFip) (Input S.empty [] [] True) of Ok x _out docs -> (x,docs) instance Functor Chk where @@ -349,6 +365,13 @@ writeOutput :: Output -> Chk () writeOutput out = Chk (\env st -> Ok () out []) +withFip :: Fip -> Chk a -> Chk a +withFip f chk + = withEnv (\env -> env{fip=f}) chk + +getFip :: Chk Fip +getFip = fip <$> getEnv + -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output extractOutput (Chk f) diff --git a/src/Core/Core.hs b/src/Core/Core.hs index fa19110de..d5121afa0 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -560,14 +560,14 @@ data InlineDef = InlineDef{ defIsVal :: Def -> Bool defIsVal def = case defSort def of - DefFun _ -> False + DefFun{} -> False _ -> True defParamInfos :: Def -> [ParamInfo] defParamInfos def = case defSort def of - DefFun pinfos -> pinfos - _ -> [] + DefFun pinfos _ -> pinfos + _ -> [] inlineDefIsSpecialize :: InlineDef -> Bool inlineDefIsSpecialize inlDef = not (null (inlineParamSpecialize inlDef)) @@ -1075,7 +1075,7 @@ addLambdasTName pars eff e = Lam pars eff e -- | Bind a variable inside a term addNonRec :: Name -> Type -> Expr -> (Expr -> Expr) addNonRec x tp e e' - = Let [DefNonRec (Def x tp e Private (if isValueExpr e then DefVal else DefFun [] {-all owned?-}) InlineAuto rangeNull "")] e' + = Let [DefNonRec (Def x tp e Private (if isValueExpr e then DefVal else defFun [] {-all owned?-}) InlineAuto rangeNull "")] e' -- | Is an expression a value or a function isValueExpr :: Expr -> Bool diff --git a/src/Core/FunLift.hs b/src/Core/FunLift.hs index 490f36fdb..598c26511 100644 --- a/src/Core/FunLift.hs +++ b/src/Core/FunLift.hs @@ -136,7 +136,7 @@ liftDef topLevel def return def{ defExpr = expr', defSort = liftSort topLevel (defSort def)} liftSort :: Bool -> DefSort -> DefSort -liftSort False (DefFun _) = DefVal +liftSort False (DefFun{}) = DefVal liftSort _ sort = sort {- diff --git a/src/Core/GenDoc.hs b/src/Core/GenDoc.hs index 7f84755f2..b0ea0674c 100644 --- a/src/Core/GenDoc.hs +++ b/src/Core/GenDoc.hs @@ -184,7 +184,7 @@ genDoc env kgamma gamma core p = map toDef (coreProgExternals core) where toDef ext = Def (externalName ext) (externalType ext) (failure "Core.GenDoc.genDoc: access to expression") - (externalVis ext) (DefFun (externalParams ext)) InlineAuto (externalRange ext) (externalDoc ext) + (externalVis ext) (defFun (externalParams ext)) InlineAuto (externalRange ext) (externalDoc ext) htmlBody pre = do mapM_ (writeLn p) (htmlHeader env (show (coreProgName core))) diff --git a/src/Core/MonadicLift.hs b/src/Core/MonadicLift.hs index 184cd7f5f..679961a50 100644 --- a/src/Core/MonadicLift.hs +++ b/src/Core/MonadicLift.hs @@ -221,7 +221,7 @@ makeDef fvs tvs expr liftedFun = addTypeLambdas alltpars $ Lam allpars eff body liftedTp = -- trace ("makeDef: liftedFun: " ++ show (prettyExpr defaultEnv{coreShowTypes=True} expr) ++ "\nraw: " ++ show expr) $ typeOf liftedFun - liftedDef name inl = Def name liftedTp liftedFun Private (DefFun [] {-all owned-}) InlineAuto rangeNull "// monadic lift" + liftedDef name inl = Def name liftedTp liftedFun Private (defFun [] {-all owned-}) InlineAuto rangeNull "// monadic lift" funExpr name = Var (TName name liftedTp) (InfoArity (length alltpars) (length allargs)) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 75ff16122..717a9f7e1 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -321,8 +321,8 @@ defDecl env keyword ":" (tp,pinfos) <- pdeftype env let sort = case sort0 of - DefFun _ -> DefFun pinfos - _ -> sort0 + DefFun _ fip -> DefFun pinfos fip + _ -> sort0 -- trace ("parse def: " ++ show name ++ ": " ++ show tp) $ return () return (Def (qualify (modName env) name) tp (error ("Core.Parse: " ++ show name ++ ": cannot get the expression from an interface core file")) vis sort inl rangeNull doc) @@ -330,13 +330,14 @@ defDecl env pdefSort = do isRec <- do{ specialId "recursive"; return True } <|> return False inl <- parseInline - (do (_,doc) <- dockeyword "fun" + (do fip <- try parseFip + (_,doc) <- dockeyword "fun" _ <- do { specialOp "**"; return ()} <|> do { specialOp "*"; return () } <|> return () - return (DefFun [],inl,isRec,doc) -- borrow info comes from type + return (defFunEx [] fip,inl,isRec,doc) -- borrow info comes from type <|> do (_,doc) <- dockeyword "val" return (DefVal,inl,False,doc)) @@ -437,8 +438,9 @@ inlineDefSort (s,_) <- stringLit return [if c == '^' then Borrow else Own | c <- s] <|> return [] - (do (_,doc) <- dockeyword "fun" - return (DefFun pinfos,inl,isRec,spec,doc) + (do fip <- try parseFip + (_,doc) <- dockeyword "fun" + return (DefFun pinfos fip,inl,isRec,spec,doc) <|> do (_,doc) <- dockeyword "val" return (DefVal,inl,False,spec,doc)) diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index c77b308ed..f850d3534 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -242,7 +242,7 @@ prettyInlineDef env (InlineDef name expr isRec inlkind cost sort specArgs) <.> (if (null specArgs) then empty else (keyword env "specialize " <.> prettySpecArgs <.> text " ")) <.> (if (cost <= 0 || inlkind == InlineAlways) then (keyword env "inline ") else empty) <.> prettyParamInfos sort - <.> keyword env (show sort) + <.> keyword env (defSortShowFull sort) <+> (if nameIsNil name then text "_" else prettyDefName env name) -- <+> text ":" <+> prettyType env scheme <+> text ("// inline size: " ++ show cost) @@ -256,7 +256,7 @@ prettyInlineDef env (InlineDef name expr isRec inlkind cost sort specArgs) prettySpecArgs = dquotes (text [if spec then '*' else '_' | spec <- specArgs]) - prettyParamInfos (DefFun pinfos) | Borrow `elem` pinfos + prettyParamInfos (DefFun{defFunParamInfos=pinfos}) | Borrow `elem` pinfos = keyword env "borrow" <+> dquotes (text [if info == Borrow then '^' else '_' | info <- pinfos]) <.> text " " prettyParamInfos _ = empty @@ -275,8 +275,8 @@ prettyDefX env isRec def@(Def name scheme expr vis sort inl nameRng doc) then text "_" else prettyDefName env name) <+> text ":" <+> (case sort of - DefFun pinfos -> prettyDefFunType env pinfos scheme - _ -> prettyType env scheme + DefFun pinfos _ -> prettyDefFunType env pinfos scheme + _ -> prettyType env scheme ) <.> (if (not (coreShowDef env)) -- && (sizeDef def >= coreInlineMax env) then empty diff --git a/src/Core/UnReturn.hs b/src/Core/UnReturn.hs index a29b456b6..ce3af148e 100644 --- a/src/Core/UnReturn.hs +++ b/src/Core/UnReturn.hs @@ -209,7 +209,7 @@ urCase org scruts branches let f c = let lam = Lam [parName] eff (c parVar) defTp = typeOf lam - def = Def name defTp lam Private (DefFun [Own]) InlineAuto rangeNull "" + def = Def name defTp lam Private (defFun [Own]) InlineAuto rangeNull "" defVar = Var (TName name defTp) InfoNone -- (InfoArity 0 1 NoMon) -- with arity C# code gets wrong app e = App defVar [e] in makeLet [DefNonRec def] $ diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 07ed77a06..66047b518 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -191,7 +191,7 @@ synCopyCon modName info con params = [ValueBinder name Nothing (if not (hasAccessor name t con) then Nothing else (Just (app (var name) [var argName]))) rc rc| (name,t) <- conInfoParams con] expr = Lam ([ValueBinder argName Nothing Nothing rc rc] ++ params) body rc body = app (var (conInfoName con)) [var name | (name,tp) <- conInfoParams con] - def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (DefFun []) InlineAuto False (Fip 0) "") + def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (defFun []) InlineAuto "") in def hasAccessor :: Name -> Type -> ConInfo -> Bool @@ -251,7 +251,7 @@ synAccessors modName info messages = [Lit (LitString (sourceName (posSource (rangeStart rng)) ++ show rng) rng), Lit (LitString (show name) rng)] doc = "// Automatically generated. Retrieves the `" ++ show name ++ "` constructor field of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (DefFun [Borrow]) InlineAlways False (Fip 0) doc) + in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (defFunEx [Borrow] noFip) InlineAlways doc) in map synAccessor fields @@ -269,14 +269,14 @@ synTester info con branch2 = Branch (PatWild rc) [Guard guardTrue (Var nameFalse False rc)] patterns = [(Nothing,PatWild rc) | _ <- conInfoParams con] doc = "// Automatically generated. Tests for the `" ++ nameId (conInfoName con) ++ "` constructor of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (DefFun [Borrow]) InlineAlways False (Fip 0) doc)] + in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (defFunEx [Borrow] (Fip 0)) InlineAlways doc)] synConstrTag :: (ConInfo) -> DefGroup Type synConstrTag (con) = let name = toOpenTagName (unqualify (conInfoName con)) rc = conInfoRange con expr = Lit (LitString (show (conInfoName con)) rc) - in DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) DefVal InlineNever False Nofip "") + in DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) DefVal InlineNever "") {--------------------------------------------------------------- Types for constructors @@ -501,9 +501,9 @@ infDefGroup (DefNonRec def) return (DefNonRec def') infDef :: (Def UserType) -> KInfer (Def Type) -infDef (Def binder rng vis isVal inl isTail fip doc) +infDef (Def binder rng vis isVal inl doc) = do binder' <- infValueBinder binder - return (Def binder' rng vis isVal inl isTail fip doc) + return (Def binder' rng vis isVal inl doc) infValueBinder (ValueBinder name () expr nameRng rng) = do expr' <- infExpr expr diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index c29ad25ae..a442dd969 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -18,7 +18,7 @@ module Syntax.Parse( parseProgramFromFile -- used by the core parser , lexParse, parseLex, LexParser, parseLexemes, parseInline - , visibility, modulepath, importAlias + , visibility, modulepath, importAlias, parseFip , tbinderId, constructorId, funid, paramid , braced, semiBraces, semis, semiColons1, semiBraced , angles, anglesCommas, parensCommas, parens, curlies @@ -38,7 +38,7 @@ import Data.Either (partitionEithers) import Lib.PPrint hiding (string,parens,integer,semiBraces,lparen,comma,angles,rparen,rangle,langle) import qualified Lib.PPrint as PP (string) -import Control.Monad (mzero) +import Control.Monad (mzero,when) import Data.Monoid (Endo(..)) import Text.Parsec hiding (space,tab,lower,upper,alphaNum,sourceName,optional) import Text.Parsec.Error @@ -170,7 +170,7 @@ expression name = interactive $ do e <- aexpr let r = getRange e - return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun []) InlineNever False Nofip "" + return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun [] noFip) InlineNever "" -- ,Def (ValueBinder (prepend ".eval" name) () (Lam [] (App (Var nameGPrint False r) [Var name False r] r))) ) @@ -353,7 +353,7 @@ externDecl dvis extern = External externName tp pinfos (before nameRng) (before fullRng) exprs Private fip doc body = annotate (Lam pars (App (Var externName False rangeNull) args fullRng) fullRng) binder = ValueBinder name () body nameRng fullRng - extfun = Def binder fullRng vis (defFun pinfos) InlineNever False fip doc + extfun = Def binder fullRng vis (defFunEx pinfos fip) InlineNever doc return [DefExtern extern, DefValue extfun] where typeFromPars :: Range -> [ValueBinder UserType (Maybe UserExpr)] -> UserType -> UserType -> UserType @@ -648,7 +648,7 @@ makeUserCon con foralls resTp exists pars nameRng rng vis doc = [(vis,par{ binderExpr = Nothing }) | (vis,par) <- pars] creator = let name = newCreatorName con - def = Def binder rng vis (defFun []) InlineAlways True Nofip doc + def = Def binder rng vis (defFun []) InlineAlways doc binder = ValueBinder name () body nameRng nameRng body = Ann (Lam lparams (App (Var con False nameRng) arguments rng) rng) tpFull rng params = [par{ binderType = (if (isJust (binderExpr par)) then makeOptional (binderType par) else binderType par) } | (_,par) <- pars] @@ -707,7 +707,7 @@ bindExprToVal opname oprange expr = let fresh = makeFreshHiddenName "value" opname oprange freshVar = (Var fresh False oprange) erange = (getRange expr) - binder = (Def (ValueBinder fresh () expr oprange erange) oprange Private DefVal InlineAuto False Nofip "") + binder = (Def (ValueBinder fresh () expr oprange erange) oprange Private DefVal InlineAuto "") in (\body -> Bind binder body erange, \params -> freshVar {- \params -> resumeCall freshVar params erange -}) @@ -850,7 +850,7 @@ makeEffectDecl decl = (quantify QForall tpars (makeTpApp (TpCon nameTpHTag krng) [makeTpApp (TpCon hndName krng) (map tpVar tparsNonScoped) krng] krng)) krng) - krng krng) krng vis DefVal InlineNever True Nofip ("// runtime tag for the " ++ docEffect) + krng krng) krng vis DefVal InlineNever ("// runtime tag for the " ++ docEffect) --extendConName = toEffectConName (tbinderName ename) @@ -907,7 +907,7 @@ makeEffectDecl decl = (Nothing, Var (newName "ret") False krng), (Nothing, wrapAction (Var (newName "action") False krng))] handleDef = Def (ValueBinder handleName () handleBody irng rng) - grng vis (defFun []) InlineNever True Nofip ("// handler for the " ++ docEffect) + grng vis (defFun []) InlineNever ("// handler for the " ++ docEffect) in [DefType effTpDecl, DefValue tagDef, DefType hndTpDecl, DefValue handleDef] ++ map DefValue opSelects @@ -1071,7 +1071,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa -- create an operation selector explicitly so we can hide the handler constructor selectId = toOpSelectorName id - opSelect = let def = Def binder krng vis (defFun [Borrow]) InlineAlways True Nofip ("// select `" ++ show id ++ "` operation out of the " ++ docEffect ++ " handler") + opSelect = let def = Def binder krng vis (defFun [Borrow]) InlineAlways ("// select `" ++ show id ++ "` operation out of the " ++ docEffect ++ " handler") nameRng = krng binder = ValueBinder selectId () body nameRng nameRng body = Ann (Lam [hndParam] innerBody grng) fullTp grng @@ -1094,7 +1094,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa -- create a typed perform wrapper: fun op(x1:a1,..,xN:aN) : b { performN(evv-at(0),clause-op,x1,..,xN) } - opDef = let def = Def binder idrng vis (DefFun []) InlineAlways True Nofip ("// call `" ++ show id ++ "` operation of the " ++ docEffect) + opDef = let def = Def binder idrng vis (defFun []) InlineAlways ("// call `" ++ show id ++ "` operation of the " ++ docEffect) nameRng = idrng binder = ValueBinder id () body nameRng nameRng body = Ann (Lam lparams innerBody rng) tpFull rng @@ -1139,7 +1139,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa phantom = App (Var namePhantom False krng) [] krng annot = Ann phantom qualTpe krng in Just $ Def (ValueBinder opName () annot idrng krng) - krng vis DefVal InlineNever True Nofip "// phantom definition for value operations" + krng vis DefVal InlineNever "// phantom definition for value operations" else Nothing @@ -1159,10 +1159,9 @@ pureDecl dvis (do (rng,doc) <- dockeyword "val" -- return (vis,vrng,rng,doc,inline,True) return (valDecl (combineRange vrng rng) doc vis inline) <|> - do isTail <- parseTail - fip <- parseFip + do fip <- parseFip (rng,doc) <- dockeywordFun -- return (vis,vrng,rng,doc,inline,False) - return (funDecl (combineRange vrng rng) doc vis inline isTail fip) + return (funDecl (combineRange vrng rng) doc vis inline fip) <|> do keyword "fn" fail "hint: use 'fun' to start a named function definition (and 'fn' for anonymous functions)") @@ -1170,29 +1169,26 @@ pureDecl dvis -- valueDecl vrng vis <|> functionDecl vrng vis pdecl -parseTail :: LexParser Bool -parseTail - = do specialId "tail" - return True - <|> return False - parseFip :: LexParser Fip parseFip - = do specialId "fip" - (n,_) <- parens integer <|> return (0,rangeNull) - return (Fip (fromInteger n)) - <|> do specialId "fbip" - (n,_) <- parens integer <|> return (0,rangeNull) - return (Fbip (fromInteger n)) - <|> return Nofip - + = do isTail <- do specialId "tail" + return True + <|> return False + ( do specialId "fip" + (n,_) <- parens integer <|> return (0,rangeNull) + when isTail $ pwarningMessage "a 'fip' function implies already 'tail'" + return (Fip (fromInteger n)) + <|> + do specialId "fbip" + (n,_) <- parens integer <|> return (0,rangeNull) + return (Fbip (fromInteger n) isTail) + <|> return (NoFip isTail)) functionDecl vrng vis = do pdecl <- try $ do inline <- parseInline - isTail <- parseTail fip <- parseFip (rng,doc) <- dockeywordFun - return (funDecl (combineRange vrng rng) doc vis inline isTail fip) + return (funDecl (combineRange vrng rng) doc vis inline fip) pdecl varDecl @@ -1200,16 +1196,16 @@ varDecl bind <- binder vrng keyword ":=" body <- blockexpr - return (Def (bind body) (combineRanged vrng body) Private DefVar InlineNever True Nofip doc) + return (Def (bind body) (combineRanged vrng body) Private DefVar InlineNever doc) valDecl rng doc vis inline = do bind <- binder rng keyword "=" body <- blockexpr - return (Def (bind body) (combineRanged rng body) vis DefVal inline True Nofip doc) + return (Def (bind body) (combineRanged rng body) vis DefVal inline doc) -funDecl rng doc vis inline isTail fip +funDecl rng doc vis inline fip = do spars <- squantifier -- tpars <- aquantifier -- todo: store somewhere (name,nameRng) <- funid @@ -1217,7 +1213,8 @@ funDecl rng doc vis inline isTail fip body <- bodyexpr let fun = promote spars tpars preds mbtres (Lam pars body (combineRanged rng body)) - return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis (defFun pinfos) inline isTail fip doc) + return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis + (defFunEx pinfos fip) inline doc) -- fundef: forall parameters, parameters, (effecttp, resulttp), annotation funDef :: Bool -> LexParser ([TypeBinder UserKind],[ValueBinder (Maybe UserType) (Maybe UserExpr)], [ParamInfo], Range, Maybe (Maybe UserType, UserType),[UserType], UserExpr -> UserExpr) @@ -1333,7 +1330,7 @@ block combine :: Statement -> UserExpr -> UserExpr combine (StatFun f) exp = f exp combine (StatExpr e) exp = let r = getRange e - in Bind (Def (ValueBinder (newName "_") () e r r) r Private DefVal InlineAuto False Nofip "") exp r + in Bind (Def (ValueBinder (newName "_") () e r r) r Private DefVal InlineAuto "") exp r combine (StatVar def) exp = let (ValueBinder name () expr nameRng rng) = defBinder def in App (Var nameLocal False rng) -- put parens over the lambda so it comes later during type inference (so the type of expr can be propagated in) @@ -1393,7 +1390,7 @@ localValueDecl Just tp -> Ann e (promoteType tp) rng Nothing -> e vbinder = ValueBinder (binderName binder) () annexpr (binderNameRange binder) (binderRange binder) - in \body -> Bind (Def vbinder rng Private DefVal InlineAuto False Nofip "") body (combineRanged krng body) + in \body -> Bind (Def vbinder rng Private DefVal InlineAuto "") body (combineRanged krng body) case unParens(pat) of PatVar (binder@ValueBinder{ binderExpr = PatWild _ }) -> return $ bindVar binder (binderType binder) (binderRange binder) diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index 6344e05e7..35fb99af3 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -197,8 +197,6 @@ data Def t , defVis :: Visibility , defSort :: DefSort , defInline :: DefInline - , defTail :: Bool - , defFip :: Fip , defDoc :: String } deriving (Show) diff --git a/src/Type/Assumption.hs b/src/Type/Assumption.hs index 989b258d5..f9ac466b4 100644 --- a/src/Type/Assumption.hs +++ b/src/Type/Assumption.hs @@ -39,7 +39,7 @@ module Type.Assumption ( import Lib.Trace import Common.Range import Common.Failure -import Common.Syntax( DefSort(..), isDefFun ) +import Common.Syntax( DefSort(..), isDefFun, defFun ) import qualified Data.List as L import Lib.PPrint import qualified Common.NameMap as M @@ -302,7 +302,7 @@ createNameInfoX vis name sort rng tp if (not (isDefFun sort)) then InfoVal vis name tp rng (sort == DefVar) else InfoFun vis name tp (getArity tp) rng createNameInfo name isVal rng tp - = createNameInfoX Public name (if isVal then DefVal else DefFun []) rng tp + = createNameInfoX Public name (if isVal then DefVal else defFun []) rng tp -- if (isVal) then InfoVal name tp rng False else InfoFun name tp (getArity tp) rng getArity :: Type -> (Int,Int) diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index e68a1c284..c3ecd826e 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -206,7 +206,7 @@ inferDefGroup topLevel (DefRec defs) cont createGammas :: [(Name,NameInfo)] -> [(Name,NameInfo)] -> [Def Type] -> Inf ([(Name,NameInfo)],[(Name,NameInfo)]) createGammas gamma infgamma [] = return (reverse gamma, reverse infgamma) - createGammas gamma infgamma (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl tail fip doc : defs) + createGammas gamma infgamma (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc : defs) = case (lookup name infgamma) of (Just _) -> do env <- getPrettyEnv @@ -439,7 +439,7 @@ inferRecDef topLevel infgamma def inferDef :: Expect -> Def Type -> Inf Core.Def -inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl tail fip doc) +inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl doc) =do penv <- getPrettyEnv if (verbose penv >= 3) then Lib.Trace.trace ("infer: " ++ show sort ++ " " ++ show name) $ return () @@ -459,7 +459,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl subst (Core.Def name resTp resCore vis sort inl nameRng doc) -- must 'subst' since the total unification can cause substitution. (see test/type/hr1a) inferBindDef :: Def Type -> Inf (Effect,Core.Def) -inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl tail fip doc) +inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc) = -- trace ("infer bind def: " ++ show name ++ ", var?:" ++ show (sort==DefVar)) $ do withDefName name $ do (tp,eff,coreExpr) <- inferExpr Nothing Instantiated expr @@ -1244,7 +1244,7 @@ inferApp propagated expect fun nargs rng if (Core.isTotal fcore) then return (Core.makeLet defs (coreApp fcore cargs)) else do fname <- uniqueName "fun" - let fdef = Core.DefNonRec (Core.Def fname ftp fcore Core.Private (DefFun [] {-all own, TODO: maintain borrow annotations?-}) InlineAuto rangeNull "") + let fdef = Core.DefNonRec (Core.Def fname ftp fcore Core.Private (defFun [] {-all own, TODO: maintain borrow annotations?-}) InlineAuto rangeNull "") fvar = Core.Var (Core.TName fname ftp) Core.InfoNone return (Core.Let (fdef:defs) (coreApp fvar cargs)) -- take top effect From b7efe5d8a27fcbf7ab6af3206c1618004954f88c Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 3 Mar 2023 09:45:55 -0800 Subject: [PATCH 153/233] propagate fip info in the assumption; add lookupFip to checkFBIP --- src/Compiler/Compile.hs | 7 ++++--- src/Core/Borrowed.hs | 2 +- src/Core/CheckFBIP.hs | 22 ++++++++++++++------ src/Core/Core.hs | 5 +++-- src/Core/Parse.hs | 9 ++++---- src/Core/Pretty.hs | 6 +++--- src/Kind/Infer.hs | 2 +- src/Type/Assumption.hs | 46 +++++++++++++++++++++++++++-------------- 8 files changed, 64 insertions(+), 35 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index b0204998f..b622d7cec 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -492,9 +492,10 @@ checkUnhandledEffects flags loaded name range tp -> let defaultHandlerName = makeHiddenName "default" effName in -- trace ("looking up: " ++ show defaultHandlerName) $ case gammaLookupQ defaultHandlerName (loadedGamma loaded) of - [InfoFun _ dname _ _ _] + [fun@InfoFun{}] -> trace ("add default effect for " ++ show effName) $ - let g mfx expr = let r = getRange expr + let dname = infoCName fun + g mfx expr = let r = getRange expr in App (Var dname False r) [(Nothing,Lam [] (maybe expr (\f -> f expr) mfx) r)] r in if (effName == nameTpAsync) -- always put async as the most outer effect then do mf' <- combine eff mf ls @@ -871,7 +872,7 @@ inferCheck loaded0 flags line coreImports program unreturn penv -- checkCoreDefs "unreturn" - checkFBIP penv (platform flags) (loadedNewtypes loaded) (loadedBorrowed loaded) + checkFBIP penv (platform flags) (loadedNewtypes loaded) (loadedBorrowed loaded) (loadedGamma loaded) -- initial simplify let ndebug = optimize flags > 0 diff --git a/src/Core/Borrowed.hs b/src/Core/Borrowed.hs index 9a9a6bd65..e44ba97e5 100644 --- a/src/Core/Borrowed.hs +++ b/src/Core/Borrowed.hs @@ -89,7 +89,7 @@ extractBorrowExternals exs extractExternal :: External -> Maybe BorrowDef extractExternal ex = case ex of - External name _ params _ _ _ _ -> + External name _ params _ _ _ _ _ -> if Borrow `elem` params then Just (name, params) else Nothing _ -> Nothing diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 52da9725a..5135ad2c0 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -52,11 +52,11 @@ trace s x = x -checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> CorePhase () -checkFBIP penv platform newtypes borrowed +checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> Gamma -> CorePhase () +checkFBIP penv platform newtypes borrowed gamma = do uniq <- unique defGroups <- getCoreDefs - let (_,docs) = runChk penv uniq platform newtypes borrowed (chkDefGroups defGroups) + let (_,docs) = runChk penv uniq platform newtypes borrowed gamma (chkDefGroups defGroups) mapM_ (\doc -> liftError (warningMsg (rangeNull, doc))) docs @@ -277,6 +277,7 @@ data Env = Env{ currentDef :: [Def], platform :: Platform, newtypes :: Newtypes, borrowed :: Borrowed, + gamma :: Gamma, fip :: Fip } @@ -325,9 +326,9 @@ prettyGammaDia ppenv (Output nm dia) data Result a = Ok a Output [Doc] -runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Chk a -> (a,[Doc]) -runChk penv u platform newtypes borrowed (Chk c) - = case c (Env [] penv platform newtypes borrowed noFip) (Input S.empty [] [] True) of +runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[Doc]) +runChk penv u platform newtypes borrowed gamma (Chk c) + = case c (Env [] penv platform newtypes borrowed gamma noFip) (Input S.empty [] [] True) of Ok x _out docs -> (x,docs) instance Functor Chk where @@ -372,6 +373,15 @@ withFip f chk getFip :: Chk Fip getFip = fip <$> getEnv +-- look up fip annotation; return noFip if not found +lookupFip :: Name -> Chk Fip +lookupFip name + = do env <- getEnv + case filter isInfoFun (gammaLookupQ name (gamma env)) of + [fun] -> return (infoFip fun) + _ -> return noFip + + -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output extractOutput (Chk f) diff --git a/src/Core/Core.hs b/src/Core/Core.hs index d5121afa0..80d9cf7c6 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -278,9 +278,10 @@ data External = External{ externalName :: Name , externalType :: Scheme , externalParams :: [ParamInfo] , externalFormat :: [(Target,String)] - , externalVis' :: Visibility + , externalVis' :: Visibility + , externalFip :: Fip , externalRange :: Range - , externalDoc :: String + , externalDoc :: String } | ExternalImport { externalImport :: [(Target,[(String,String)])] , externalRange :: Range } diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 717a9f7e1..a7ea9080e 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -347,15 +347,16 @@ pdefSort --------------------------------------------------------------------------} externDecl :: Env -> LexParser External externDecl env - = do (vis,doc) <- try $ do vis <- vispub - (_,doc) <- dockeyword "extern" - return (vis,doc) + = do (vis,fip,doc) <- try $ do vis <- vispub + fip <- parseFip + (_,doc) <- dockeyword "extern" + return (vis,fip,doc) (name,_) <- (funid) -- trace ("core def: " ++ show name) $ return () keyword ":" (tp,pinfos) <- pdeftype env formats <- externalBody - return (External (qualify (modName env) name) tp pinfos formats vis rangeNull doc) + return (External (qualify (modName env) name) tp pinfos formats vis fip rangeNull doc) externalBody :: LexParser [(Target,String)] diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index f850d3534..0214a3c3c 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -156,12 +156,12 @@ prettyImportedSyn env synInfo = ppSynInfo env True False True synInfo <.> semi prettyExternal :: Env -> External -> Doc -prettyExternal env (External name tp pinfos body vis nameRng doc) | coreIface env && isHiddenExternalName name +prettyExternal env (External name tp pinfos body vis fip nameRng doc) | coreIface env && isHiddenExternalName name = empty -prettyExternal env (External name tp pinfos body vis nameRng doc) +prettyExternal env (External name tp pinfos body vis fip nameRng doc) = prettyComment env doc $ prettyVis env vis $ - keyword env "extern" <+> prettyDefName env name <+> text ":" <+> prettyDefFunType env pinfos tp <+> prettyEntries body + keyword env (show fip ++ "extern") <+> prettyDefName env name <+> text ":" <+> prettyDefFunType env pinfos tp <+> prettyEntries body where prettyEntries [(Default,content)] = keyword env "= inline" <+> prettyLit env (LitString content) <.> semi prettyEntries entries = text "{" <-> tab (vcat (map prettyEntry entries)) <-> text "};" diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 66047b518..727622f71 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -409,7 +409,7 @@ infExternal names (External name tp pinfos nameRng rng calls vis fip doc) addRangeInfo rng (Decl "external" qname (mangle cname tp')) -- trace ("infExternal: " ++ show cname ++ ": " ++ show (pretty tp')) $ return (Core.External cname tp' pinfos (map (formatCall tp') calls) - vis nameRng doc, qname:names) + vis fip nameRng doc, qname:names) infExternal names (ExternalImport imports range) = return (Core.ExternalImport imports range, names) diff --git a/src/Type/Assumption.hs b/src/Type/Assumption.hs index f9ac466b4..615eec141 100644 --- a/src/Type/Assumption.hs +++ b/src/Type/Assumption.hs @@ -25,8 +25,10 @@ module Type.Assumption ( , isInfoImport , isInfoFun , isInfoValFunExt + , isInfoFunOrExternal , infoElement , infoCanonicalName + , fipFromNameInfo -- * From Core , extractGammaImports , extractGamma @@ -39,7 +41,7 @@ module Type.Assumption ( import Lib.Trace import Common.Range import Common.Failure -import Common.Syntax( DefSort(..), isDefFun, defFun ) +import Common.Syntax( DefSort(..), isDefFun, defFun, Fip, noFip ) import qualified Data.List as L import Lib.PPrint import qualified Common.NameMap as M @@ -56,9 +58,9 @@ import Lib.Trace data NameInfo = InfoVal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoRange :: Range, infoIsVar :: Bool } - | InfoFun{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoArity :: (Int,Int), infoRange :: Range } + | InfoFun{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoArity :: (Int,Int), infoFip :: Fip, infoRange :: Range } | InfoCon{ infoVis :: Visibility, infoType :: Scheme, infoRepr :: Core.ConRepr, infoCon :: ConInfo, infoRange :: Range } - | InfoExternal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoFormat :: [(Target,String)], infoRange :: Range } + | InfoExternal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoFormat :: [(Target,String)], infoFip :: Fip, infoRange :: Range } | InfoImport{ infoVis :: Visibility, infoType :: Scheme, infoAlias :: Name, infoFullName :: Name, infoRange :: Range } deriving (Show) @@ -88,6 +90,17 @@ isInfoFun :: NameInfo -> Bool isInfoFun (InfoFun{}) = True isInfoFun _ = False +isInfoFunOrExternal :: NameInfo -> Bool +isInfoFunOrExternal (InfoFun{}) = True +isInfoFunOrExternal (InfoExternal{}) = True +isInfoFunOrExternal _ = False + +fipFromNameInfo :: NameInfo -> Fip +fipFromNameInfo (InfoFun{infoFip=fip}) = fip +fipFromNameInfo (InfoExternal{infoFip=fip}) = fip +fipFromNameInfo _ = noFip + + infoElement :: NameInfo -> String infoElement info = case info of @@ -104,19 +117,19 @@ infoIsVisible info = case infoVis info of coreVarInfoFromNameInfo :: NameInfo -> Core.VarInfo coreVarInfoFromNameInfo info = case info of - InfoVal _ _ tp _ _ -> Core.InfoNone - InfoFun _ _ tp (m,n) _ -> Core.InfoArity m n - InfoExternal _ _ tp format _ -> Core.InfoExternal format - _ -> matchFailure "Type.Infer.coreVarInfoFromNameInfo" + InfoVal _ _ tp _ _ -> Core.InfoNone + InfoFun _ _ tp (m,n) _ _ -> Core.InfoArity m n + InfoExternal _ _ tp format _ _ -> Core.InfoExternal format + _ -> matchFailure "Type.Infer.coreVarInfoFromNameInfo" coreExprFromNameInfo qname info = -- trace ("create name: " ++ show qname) $ case info of - InfoVal vis cname tp _ _ -> Core.Var (Core.TName cname tp) (Core.InfoNone) - InfoFun vis cname tp ((m,n)) _ -> Core.Var (Core.TName cname tp) (Core.InfoArity m n) - InfoCon vis tp repr _ _ -> Core.Con (Core.TName qname tp) repr - InfoExternal vis cname tp format _ -> Core.Var (Core.TName cname tp) (Core.InfoExternal format) - InfoImport _ _ _ _ _ -> matchFailure "Type.Infer.coreExprFromNameInfo" + InfoVal vis cname tp _ _ -> Core.Var (Core.TName cname tp) (Core.InfoNone) + InfoFun vis cname tp ((m,n)) _ _ -> Core.Var (Core.TName cname tp) (Core.InfoArity m n) + InfoCon vis tp repr _ _ -> Core.Con (Core.TName qname tp) repr + InfoExternal vis cname tp format _ _ -> Core.Var (Core.TName cname tp) (Core.InfoExternal format) + InfoImport _ _ _ _ _ -> matchFailure "Type.Infer.coreExprFromNameInfo" {-------------------------------------------------------------------------- @@ -299,7 +312,10 @@ coreDefInfo def@(Core.Def name tp expr vis sort inl nameRng doc) createNameInfoX :: Visibility -> Name -> DefSort -> Range -> Type -> NameInfo createNameInfoX vis name sort rng tp = -- trace ("createNameInfoX: " ++ show name ++ ", " ++ show sort ++ ": " ++ show (pretty tp)) $ - if (not (isDefFun sort)) then InfoVal vis name tp rng (sort == DefVar) else InfoFun vis name tp (getArity tp) rng + case sort of + DefFun _ fip -> InfoFun vis name tp (getArity tp) fip rng + DefVar -> InfoVal vis name tp rng True + _ -> InfoVal vis name tp rng False createNameInfo name isVal rng tp = createNameInfoX Public name (if isVal then DefVal else defFun []) rng tp @@ -316,8 +332,8 @@ getArity tp _ -> failure ("Type.Assumption.createNameInfo.getArity: illegal type?" ++ show tp) -extractExternal updateVis (Core.External name tp pinfos body vis nameRng doc) - = gammaSingle (nonCanonicalName name) (InfoExternal (updateVis vis) name tp body nameRng) +extractExternal updateVis (Core.External name tp pinfos body vis fip nameRng doc) + = gammaSingle (nonCanonicalName name) (InfoExternal (updateVis vis) name tp body fip nameRng) extractExternal updateVis _ = gammaEmpty From 0a7ad2c213c4b1afc0a095868bf57f2938496667 Mon Sep 17 00:00:00 2001 From: Daan Date: Fri, 3 Mar 2023 11:56:02 -0800 Subject: [PATCH 154/233] fix borrow extraction --- src/Compiler/Compile.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index b622d7cec..97b5080d2 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -64,7 +64,7 @@ import Core.FunLift ( liftFunctions ) import Core.Monadic ( monTransform ) import Core.MonadicLift ( monadicLift ) import Core.Inlines ( inlinesExtends, extractInlineDefs, inlinesMerge, inlinesToList, inlinesFilter, inlinesNew ) -import Core.Borrowed ( Borrowed ) +import Core.Borrowed ( Borrowed, borrowedExtendICore ) import Core.Inline ( inlineDefs ) import Core.Specialize import Core.Unroll ( unrollDefs ) @@ -871,8 +871,8 @@ inferCheck loaded0 flags line coreImports program -- remove return statements unreturn penv -- checkCoreDefs "unreturn" - - checkFBIP penv (platform flags) (loadedNewtypes loaded) (loadedBorrowed loaded) (loadedGamma loaded) + let borrowed = borrowedExtendICore (coreProgram{ Core.coreProgDefs = cdefs }) (loadedBorrowed loaded) + checkFBIP penv (platform flags) (loadedNewtypes loaded) borrowed (loadedGamma loaded) -- initial simplify let ndebug = optimize flags > 0 From 29921ed4894eec7cf201956dd6bea41aa8e2df31 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Sat, 4 Mar 2023 21:18:34 +0000 Subject: [PATCH 155/233] Extend fbip analysis --- src/Core/CheckFBIP.hs | 135 ++++++++++++++++++++++++++++++++---------- 1 file changed, 104 insertions(+), 31 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 5135ad2c0..204cfe783 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- --- Check if a function is FBIP +-- Check if a function is FIP/FBIP ----------------------------------------------------------------------------- module Core.CheckFBIP( checkFBIP @@ -46,6 +46,7 @@ import Core.Borrowed import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) import Backend.C.ParcReuse (getFixedDataAllocSize) import Backend.C.Parc (getDataDef') +import Data.List (tails) trace s x = Lib.Trace.trace s @@ -124,9 +125,9 @@ chkExpr expr gamma2 <- bindName (defTName def) Nothing out writeOutput gamma2 withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ - withNonTailCtx $ chkExpr $ defExpr def + withTailMod [Let dgs body] $ chkExpr $ defExpr def Let _ _ - -> unhandled $ text "FBIP check can not handle recursive let bindings." + -> unhandled $ text "FIP check can not handle recursive let bindings." Case scrutinees branches -> chkBranches scrutinees branches @@ -136,28 +137,33 @@ chkExpr expr chkModCons :: [Expr] -> Chk () chkModCons [] = pure () chkModCons args - = do let (larg:rargs) = reverse args - withNonTailCtx $ mapM_ chkExpr rargs - chkExpr larg -- can be tail-mod-cons + = zipWithM_ (\a tl -> withTailMod tl $ chkExpr a) args (tail $ tails args) chkBranches :: [Expr] -> [Branch] -> Chk () chkBranches scrutinees branches - = do whichBorrowed <- mapM chkScrutinee scrutinees + = do whichBorrowed <- mapM isBorrowedScrutinee scrutinees let branches' = filter (not . isPatternMatchError) branches outs <- mapM (extractOutput . chkBranch whichBorrowed) branches' - writeOutput =<< joinContexts (map branchPatterns branches') outs + gamma2 <- joinContexts (map branchPatterns branches') outs + writeOutput gamma2 + withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ + withTailModBranches branches' $ -- also filter out pattern match errors + mapM_ chkScrutinee scrutinees where fromVar (Var tname _) = Just tname fromVar _ = Nothing -chkScrutinee :: Expr -> Chk ParamInfo +isBorrowedScrutinee :: Expr -> Chk ParamInfo +isBorrowedScrutinee expr@(Var tname info) + = do b <- isBorrowed tname + pure $ if b then Borrow else Own +isBorrowedScrutinee _ = pure Own + +chkScrutinee :: Expr -> Chk () chkScrutinee expr@(Var tname info) = do b <- isBorrowed tname unless b $ markSeen tname info - pure (if b then Borrow else Own) -chkScrutinee expr - = do withNonTailCtx $ chkExpr expr - pure Own +chkScrutinee expr = chkExpr expr chkBranch :: [ParamInfo] -> Branch -> Chk () chkBranch whichBorrowed (Branch pats guards) @@ -171,7 +177,7 @@ chkGuard :: Guard -> Chk () chkGuard (Guard test expr) = do out <- extractOutput $ chkExpr expr withBorrowed (S.map getName $ M.keysSet $ gammaNm out) $ - withNonTailCtx $ chkExpr test + withNonTail $ chkExpr test writeOutput out -- | We ignore default branches that create a pattern match error @@ -205,15 +211,14 @@ chkApp (Con cname repr) args -- try reuse chkAllocation cname repr chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) - withNonTailCtx $ mapM_ chkArg $ zipDefault Own bs args + withNonTail $ mapM_ chkArg $ zipDefault Own bs args + -- checkFunCallable (getName tname) =<< getFip input <- getInput - unless (isTailContext input) $ - requireCapability HasStack $ \ppenv -> - if getName tname `elem` defGroupNames input - then Just $ cat [text "Non-tail call to (mutually) recursive function: ", ppName ppenv (getName tname)] - else Nothing + unless (isTailContext input || getName tname `notElem` defGroupNames input) $ + requireCapability HasStack $ \ppenv -> Just $ + cat [text "Non-tail call to (mutually) recursive function: ", ppName ppenv (getName tname)] chkApp fn args -- local function - = do withNonTailCtx $ mapM_ chkExpr args + = do withNonTail $ mapM_ chkExpr args isBapp <- case fn of -- does the bapp rule apply? Var tname _ -> isBorrowed tname _ -> pure False @@ -224,11 +229,16 @@ chkApp fn args -- local function chkArg :: (ParamInfo, Expr) -> Chk () chkArg (Own, expr) = chkExpr expr -chkArg (Borrow, Var tname info) = markBorrowed tname info chkArg (Borrow, expr) - = do chkExpr expr - requireCapability HasDealloc $ \ppenv -> Just $ - text "Passing owned expressions as borrowed require deallocation." + = case expr of + (TypeLam _ fn) -> chkArg (Borrow, fn) + (TypeApp fn _) -> chkArg (Borrow, fn) + (App (TypeApp (Var openName _) _) [fn]) | getName openName == nameEffectOpen + -> chkArg (Borrow, fn) -- disregard .open calls + (Var tname info) -> markBorrowed tname info + _ -> do chkExpr expr + requireCapability HasDealloc $ \ppenv -> Just $ + text $ "Passing owned expressions as borrowed requires deallocation: " ++ show expr chkLit :: Lit -> Chk () chkLit lit @@ -243,7 +253,7 @@ chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - unhandled $ text "FBIP analysis detected that a top-level function was wrapped." + unhandled $ text "FIP analysis detected that a top-level function was wrapped." chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () @@ -258,7 +268,7 @@ chkAllocation cname crepr chkEffect :: Tau -> Chk () chkEffect tp = if isFBIPExtend tp then pure () else - unhandled $ text "Algebraic effects other than are not FBIP." + unhandled $ text "Algebraic effects other than are not FIP/FBIP." where isFBIPExtend tp = case extractEffectExtend tp of (taus, tau) -> all isFBIP taus @@ -373,6 +383,30 @@ withFip f chk getFip :: Chk Fip getFip = fip <$> getEnv +isCallableFrom :: Fip -> Fip -> Bool +isCallableFrom (Fip _) _ = True +isCallableFrom (Fbip _ _) (Fbip _ _) = True +isCallableFrom (Fbip _ _) (NoFip _) = True +isCallableFrom (NoFip _) (NoFip _) = True +isCallableFrom _ _ = False + +-- TODO: `gammaLookupQ` does not seem to work within the current module +checkFunCallable :: Name -> Fip -> Chk () +checkFunCallable fn fip + = do g <- gamma <$> getEnv + let xs = gammaLookupQ fn g + case xs of + [info] -> case info of + InfoFun _ _ _ _ fip' _ + -> if fip' `isCallableFrom` fip then pure () + else emitWarning $ text $ "Non-FIP function called: " ++ show fn + Type.Assumption.InfoExternal _ _ _ _ fip' _ + -> if fip' `isCallableFrom` fip then pure () + else emitWarning $ text $ "Non-FIP function called: " ++ show fn + _ -> pure () + [] -> emitWarning $ text $ "FIP analysis couldn't find FIP information for function: " ++ show fn + _ -> emitWarning $ text $ "FIP analysis found ambiguous FIP information for function: " ++ show fn + -- look up fip annotation; return noFip if not found lookupFip :: Name -> Chk Fip lookupFip name @@ -413,10 +447,49 @@ unhandled doc = do hasAll <- and <$> mapM hasCapability (enumFromTo minBound maxBound) unless hasAll $ emitWarning doc -withNonTailCtx :: Chk a -> Chk a -withNonTailCtx +withNonTail :: Chk a -> Chk a +withNonTail = withInput (\st -> st { isTailContext = False }) +withTailModBranches :: [Branch] -> Chk a -> Chk a +withTailModBranches [Branch _ [Guard test expr]] | isExprTrue test + = withTailMod [expr] +withTailModBranches _ = withNonTail + +withTailMod :: [Expr] -> Chk a -> Chk a +withTailMod modExpr + = withInput (\st -> st { isTailContext = isTailContext st && all isModCons modExpr }) + +isModCons :: Expr -> Bool +isModCons expr + = case expr of + Var _ _ -> True + TypeLam _ e -> isModCons e + TypeApp e _ -> isModCons e + Con _ _ -> True + Lit _ -> True + Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModCons e + App f args -> isModConsFun f && all isModCons args + _ -> False + where + isModConsBranch (Branch pat guards) = all isModConsGuard guards + isModConsGuard (Guard test expr) = isModCons test && isModCons expr + +isModConsFun :: Expr -> Bool +isModConsFun expr + = case expr of + TypeLam _ e -> isModConsFun e + TypeApp e _ -> isModConsFun e + Con _ _ -> True + Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModConsFun e + App f args -> hasTotalEffect (typeOf expr) && isModConsFun f && all isModCons args + _ -> False + where + isModConsBranchFun (Branch pat guards) = all isModConsGuardFun guards + isModConsGuardFun (Guard test expr) = isModCons test && isModConsFun expr + +isModConsDef def = isModCons (defExpr def) + withBorrowed :: S.Set Name -> Chk a -> Chk a withBorrowed names action = withInput (\st -> st { delta = S.union names (delta st) }) action @@ -534,11 +607,11 @@ checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ text $ "FBIP analysis failed as it didn't bind a name: " ++ show nm + -> emitWarning $ text $ "FIP analysis failed as it didn't bind a name: " ++ show nm case M.maxViewWithKey $ gammaDia out of Just ((sz, c:_), _) | sz > 0 -> requireCapability HasAlloc $ \ppenv -> Just $ - cat [text "Unreused constructor: ", prettyCon ppenv c sz] + cat [text "Allocated constructor without reuse token: ", prettyCon ppenv c sz] _ -> pure () zipDefault :: a -> [a] -> [b] -> [(a, b)] From f2c60b781610b36a904d540eb72e8ebbc1c58ff7 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Sat, 4 Mar 2023 21:43:24 +0000 Subject: [PATCH 156/233] Fix chkFunCallable --- src/Compiler/Compile.hs | 2 +- src/Core/CheckFBIP.hs | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 97b5080d2..c65242365 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -872,7 +872,7 @@ inferCheck loaded0 flags line coreImports program unreturn penv -- checkCoreDefs "unreturn" let borrowed = borrowedExtendICore (coreProgram{ Core.coreProgDefs = cdefs }) (loadedBorrowed loaded) - checkFBIP penv (platform flags) (loadedNewtypes loaded) borrowed (loadedGamma loaded) + checkFBIP penv (platform flags) (loadedNewtypes loaded) borrowed gamma -- initial simplify let ndebug = optimize flags > 0 diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 204cfe783..4f9c79fab 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -212,7 +212,7 @@ chkApp (Con cname repr) args -- try reuse chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) withNonTail $ mapM_ chkArg $ zipDefault Own bs args - -- checkFunCallable (getName tname) =<< getFip + chkFunCallable (getName tname) =<< getFip input <- getInput unless (isTailContext input || getName tname `notElem` defGroupNames input) $ requireCapability HasStack $ \ppenv -> Just $ @@ -390,11 +390,10 @@ isCallableFrom (Fbip _ _) (NoFip _) = True isCallableFrom (NoFip _) (NoFip _) = True isCallableFrom _ _ = False --- TODO: `gammaLookupQ` does not seem to work within the current module -checkFunCallable :: Name -> Fip -> Chk () -checkFunCallable fn fip +chkFunCallable :: Name -> Fip -> Chk () +chkFunCallable fn fip = do g <- gamma <$> getEnv - let xs = gammaLookupQ fn g + let xs = gammaLookupCanonical fn g case xs of [info] -> case info of InfoFun _ _ _ _ fip' _ @@ -405,7 +404,7 @@ checkFunCallable fn fip else emitWarning $ text $ "Non-FIP function called: " ++ show fn _ -> pure () [] -> emitWarning $ text $ "FIP analysis couldn't find FIP information for function: " ++ show fn - _ -> emitWarning $ text $ "FIP analysis found ambiguous FIP information for function: " ++ show fn + infos -> emitWarning $ text $ "FIP analysis found ambiguous FIP information for function: " ++ show fn ++ "\n" ++ show infos -- look up fip annotation; return noFip if not found lookupFip :: Name -> Chk Fip From dad3408886aba778ee494d086a9efc892767d6f9 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 20 Mar 2023 13:39:10 -0700 Subject: [PATCH 157/233] update mimalloc to latest --- kklib/mimalloc | 2 +- src/Backend/C/FromCore.hs | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index 28cf67e5b..a582d760e 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit 28cf67e5b64c704cad993c71f29a24e781bee544 +Subproject commit a582d760ed8266af9fab445bf3e06e65d073a6f3 diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 0311a0007..b7d326d47 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -445,10 +445,12 @@ genTypeDefPre (Data info isExtend) -- generate the type declaration if (dataRepr == DataEnum) then let enumIntTp = case (dataInfoDef info) of - DataDefValue (ValueRepr 1 0 _) -> "uint8_t" - DataDefValue (ValueRepr 2 0 _) -> "uint16_t" - DataDefValue (ValueRepr 4 0 _) -> "uint32_t" - _ -> "uint64_t" + DataDefValue (ValueRepr n 0 _) + -> if (n <= 1) then "uint8_t" + else if (n <= 2) then "uint16_t" + else if (n <= 4) then "uint32_t" + else "uint64_t" + _ -> "kk_intb_t" -- should not happen? ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> From 2750ec4675e51dd497d964d2e40f3f9d331fe7c0 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Tue, 2 May 2023 16:27:54 -0700 Subject: [PATCH 158/233] Add FIP benchmarks --- test/fip/README.md | 51 +++ test/fip/bench.sh | 373 ++++++++++++++++++ test/fip/src/finger/finger_fip.kk | 285 +++++++++++++ test/fip/src/finger/finger_std.kk | 112 ++++++ test/fip/src/rbtree/rbtree_clrs.c | 183 +++++++++ test/fip/src/rbtree/rbtree_clrs_full.c | 187 +++++++++ .../src/rbtree/rbtree_clrs_full_mimalloc.c | 188 +++++++++ test/fip/src/rbtree/rbtree_clrs_mimalloc.c | 184 +++++++++ test/fip/src/rbtree/rbtree_fip.kk | 91 +++++ test/fip/src/rbtree/rbtree_fip_noreuse.kk | 91 +++++ test/fip/src/rbtree/rbtree_icfp.kk | 77 ++++ test/fip/src/rbtree/rbtree_std.kk | 91 +++++ test/fip/src/rbtree/rbtree_std_noreuse.kk | 91 +++++ test/fip/src/sort/sort_merge_fip.kk | 148 +++++++ test/fip/src/sort/sort_merge_std.kk | 58 +++ test/fip/src/sort/sort_quick_fip.kk | 104 +++++ test/fip/src/sort/sort_quick_std.kk | 40 ++ test/fip/src/tmap/tmap_fip.c | 101 +++++ test/fip/src/tmap/tmap_fip.kk | 47 +++ test/fip/src/tmap/tmap_fip_mimalloc.c | 102 +++++ test/fip/src/tmap/tmap_fip_noreuse.kk | 47 +++ test/fip/src/tmap/tmap_std.c | 82 ++++ test/fip/src/tmap/tmap_std.kk | 34 ++ test/fip/src/tmap/tmap_std_mimalloc.c | 83 ++++ test/fip/src/tmap/tmap_std_noreuse.kk | 34 ++ 25 files changed, 2884 insertions(+) create mode 100644 test/fip/README.md create mode 100755 test/fip/bench.sh create mode 100644 test/fip/src/finger/finger_fip.kk create mode 100644 test/fip/src/finger/finger_std.kk create mode 100644 test/fip/src/rbtree/rbtree_clrs.c create mode 100644 test/fip/src/rbtree/rbtree_clrs_full.c create mode 100644 test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c create mode 100644 test/fip/src/rbtree/rbtree_clrs_mimalloc.c create mode 100644 test/fip/src/rbtree/rbtree_fip.kk create mode 100644 test/fip/src/rbtree/rbtree_fip_noreuse.kk create mode 100644 test/fip/src/rbtree/rbtree_icfp.kk create mode 100644 test/fip/src/rbtree/rbtree_std.kk create mode 100644 test/fip/src/rbtree/rbtree_std_noreuse.kk create mode 100644 test/fip/src/sort/sort_merge_fip.kk create mode 100644 test/fip/src/sort/sort_merge_std.kk create mode 100644 test/fip/src/sort/sort_quick_fip.kk create mode 100644 test/fip/src/sort/sort_quick_std.kk create mode 100644 test/fip/src/tmap/tmap_fip.c create mode 100644 test/fip/src/tmap/tmap_fip.kk create mode 100644 test/fip/src/tmap/tmap_fip_mimalloc.c create mode 100644 test/fip/src/tmap/tmap_fip_noreuse.kk create mode 100644 test/fip/src/tmap/tmap_std.c create mode 100644 test/fip/src/tmap/tmap_std.kk create mode 100644 test/fip/src/tmap/tmap_std_mimalloc.c create mode 100644 test/fip/src/tmap/tmap_std_noreuse.kk diff --git a/test/fip/README.md b/test/fip/README.md new file mode 100644 index 000000000..e8d9f630d --- /dev/null +++ b/test/fip/README.md @@ -0,0 +1,51 @@ +# Benchmarking + +Run in the `bench` directory as: +``` +./bench.sh allb build run +``` + +Options: + +* `allb`: all benchmarks (also `allkk` and `allml` to select a subset, or `tmapkk`, `mapkk`, `rbtreekk`, or `kskk`). +* `build`: build benchmarks. +* `run`: run benchmarks and show benchmark scores (calculating median and stddev). +* `-n=<`N`>`: run each benchmark N times. +* `koka=`: set koka compiler command explicitly. +* `ocamlopt=`: set ocamlopt command explicitly. +* `ccomp=`: set C compiler for Koka, either `clang` or `gcc` (or `gcc-`). +* `small`: do a small run for lists 0, 1, and 10. + +The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. + +# Prerequisites + +## GNU time +Install gnu time if you don't have it: +``` +# /usr/bin/time --version +GNU time 1.7 +``` + +## Koka Dev. + +Pull the `dev` branch of koka and build it. +Modify the `bench.sh` script to let `koka_dev_dir` point +to the development directory. + +## Mimalloc + +The `*_mimalloc.c` benchmarks rely on mimalloc: + +``` +# git clone https://github.com/microsoft/mimalloc +# cd mimalloc +# mkdir -p out/release +# cd out/release +# cmake ../.. +# make +# sudo make install +``` + +The `build_c` function in `bench.sh` links against mimalloc. +This was only tested on Mac OS X and may have to be modified for other systems. \ No newline at end of file diff --git a/test/fip/bench.sh b/test/fip/bench.sh new file mode 100755 index 000000000..88d8f4eb0 --- /dev/null +++ b/test/fip/bench.sh @@ -0,0 +1,373 @@ + + +# list sizes +runparams="1 10 100 1000 10000 100000 1000000" +runparams_small="1 10 100 1000" +dirs="tmap rbtree finger sort" + +benches_tmapkk="tmap/tmap_std.kk tmap/tmap_fip.kk tmap/tmap_std_noreuse.kk tmap/tmap_fip_noreuse.kk" +benches_tmapc="tmap/tmap_std_mimalloc.c tmap/tmap_fip_mimalloc.c tmap/tmap_std.c tmap/tmap_fip.c" +benches_rbtreekk="rbtree/rbtree_icfp.kk rbtree/rbtree_std.kk rbtree/rbtree_fip.kk rbtree/rbtree_std_noreuse.kk rbtree/rbtree_fip_noreuse.kk" +benches_rbtreec="rbtree/rbtree_clrs_mimalloc.c rbtree/rbtree_clrs_full_mimalloc.c rbtree/rbtree_clrs.c rbtree/rbtree_clrs_full.c" +benches_sortkk="sort/sort_merge_std.kk sort/sort_merge_fip.kk sort/sort_quick_std.kk sort/sort_quick_fip.kk" +benches_fingerkk="finger/finger_std.kk finger/finger_fip.kk" +benches_all="$benches_tmapkk $benches_tmapc $benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk" + +# get this by running `stack path | grep local-install-root`` in the koka development directory +# koka_install_dir="/mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/665c0f3ba306de11186f0f92ea0ca8305283b035f4fa2dfb5c2b12a96689073b/8.10.7" +# koka_install_dir="/Users/daan/dev/koka/.stack-work/install/aarch64-osx/b63e887d74237da23db5e39821e14b1f1662540a2b2d9c63219cb143bf61a966/8.10.7" +koka_install_dir="/Users/anton/orga/phd/koka/.stack-work/install/aarch64-osx/1a7c21de82e435443ed6a5394d51d0409374699330e76b45953b1b5661520371/8.10.7" + +# if kokainstall does not exist, try to find it from the local koka development directory +koka_dev_dir="../../../koka" + +if ! [ -d "$koka_install_dir" ]; then + if [ -d "$koka_dev_dir" ]; then + pushd "$koka_dev_dir" + koka_install_dir=`stack path | grep local-install-root` + koka_install_dir="${koka_install_dir#local-install-root: }" + popd + fi +fi + +koka="${koka_install_dir}/bin/koka" +koka_ver="v2.4.1" + +echo "using koka: $koka" + +coutdir=".koka/ccomp" +copts="" + +gtime="/usr/bin/time" +if command -v "gtime"; then + gtime=`which gtime` +fi + +ccomp="clang" +benches="" + +kkopts="" +benchdir="src" +verbose="no" + +do_build="no" +do_run="no" +do_avg="no" +do_graph="no" +max_runs=1 + +trap ctrl_c INT + +function ctrl_c() { + echo "Ctrl + C happened" + exit +} + +function ensure_dir { + if ! [ -d "$1" ]; then + mkdir -p "$1" + fi +} + +function info { + echo $1 +} + +function warning { + echo "" + echo "warning: $1" +} + +ensure_dir "log" +ensure_dir ".koka/ccomp" + +while : ; do + # set flag and flag_arg + flag="$1" + case "$flag" in + *=*) flag_arg="${flag#*=}" + flag="${flag%=*}";; + no-*) flag_arg="0" + flag="${flag#no-}";; + none) flag_arg="0" ;; + *) flag_arg="1" ;; + esac + case "$flag_arg" in + yes|on|true) flag_arg="1";; + no|off|false) flag_arg="0";; + esac + case "$flag" in + "") break;; + + allb) benches="$benches_all";; + + allkk) benches="$benches $benches_tmapkk $benches_rbtreekk $benches_fingerkk $benches_sortkk";; + tmapkk) benches="$benches $benches_tmapkk";; + rbtreekk) benches="$benches $benches_rbtreekk";; + sortkk) benches="$benches $benches_sortkk";; + fingerkk) benches="$benches $benches_fingerkk";; + allc) benches="$benches $benches_tmapc $benches_rbtreec";; + tmapc) benches="$benches $benches_tmapc";; + rbtreec) benches="$benches $benches_rbtreec";; + + ccomp) ccomp="$flag_arg";; + gcc) ccomp="gcc";; + clang) ccomp="clang";; + + build) do_build="yes";; + run) do_run="yes" + do_avg="yes";; + graph) do_graph="yes";; + avg) do_avg="yes";; + + asm) kkopts="$kkopts --core --ccopts=-save-temps";; + core) kkopts="$kkopts --core";; + nounroll) kkopts="--fno-unroll";; + + koka) koka="$flag_arg";; + ocamlopt) ocamlopt="$flag_arg";; + + small) runparams="$runparams_small";; + + -n|-i) + max_runs=$flag_arg;; + + -v|--verbose) + verbose="yes";; + -h|--help|-\?|help|\?) + echo "./bench.sh [options]" + echo "" + echo "options:" + echo " -h, --help show this help" + echo " -v, --verbose be verbose (=$verbose)" + echo "" + exit 0;; + *) warning "unknown option \"$1\"." 1>&2 + esac + shift +done + +function build_kk { # + local options="-O2 --no-debug --fstdalloc --cc=$ccomp --buildtag=bench $kkopts" + if [[ "$1" == *"noreuse.kk"* ]]; then + options="$options --fno-reuse" + fi + info "" + info "build: $1, ($options)" + "$koka" $options -i$benchdir $benchdir/$1 +} + +function build_c { # + local base=${1%.*} + local dbase=${base//\//_} + local options="-O3 -o $coutdir/$dbase $copts" + if [[ $(uname -m) == 'arm64' ]]; then + options="$options -mcpu=apple-m1" + else + options="$options -march=native" + fi + if [[ "$1" == *"mimalloc.c"* ]]; then + options="$options -L /usr/local/lib/mimalloc-2.0 -I /usr/local/include/mimalloc-2.0 -lmimalloc" + fi + info "" + info "build: $1, ($options)" + "$ccomp" $options $benchdir/$1 +} + +function build_all { + for bench in $benches; do + if ! [ -f "$benchdir/$bench" ]; then + info "skip $bench -- not found" + elif [[ $bench == *\.kk ]]; then + build_kk $bench $ccomp + elif [[ $bench == *\.c ]]; then + build_c $bench + else + warning "define build compiler for $bench" + fi + done +} + +function run { #bname cmd runidx log runparam + info "" + info "run $1, iter $3, cmd: $2" + local logrun="./log/run.txt" + $gtime -o $logrun -f "elapsed: %es, user: %Us, sys: %Ss, rss: %Mkb" $2 $5 + cat $logrun + # extract elapsed time + local line=`head -1 $logrun` + local elapsed=${line#elapsed: } + elapsed=${elapsed/s,*/} + local rss=${line#*rss: } + rss=${rss/kb*/} + echo "$elapsed $rss" >> "$4" +} + +function run_all { + for bench in $benches; do + local exe="" + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local dbase=${base//\//_} + + if [[ $bench == *\.kk ]]; then + exe=".koka/${koka_ver}-bench/$ccomp-release/$dbase" + elif [[ $bench == *\.c ]]; then + exe=".koka/ccomp/$dbase" + fi + + local cmd="$exe" + if ! [ -f $exe ]; then + info "bench $base: NA (exe not found: $exe)" + elif [ -z $cmd ]; then + info "bench $base: NA (no command)" # define for ML + else + for runparam in $runparams; do + local bname="${prefix}_${dbase}_$runparam" + local log="./log/$bname.txt" + rm -f $log 2> /dev/null + for ((runs=1; runs<=$max_runs; runs++)); do + run $bname $cmd $runs $log $runparam + done + done + fi + done +} + + +basetime="" + +function avg { #bname log logbench $4= map + local median="0.01" + local stddev="0" + local rss="0" + if [ -f "$2" ]; then + local median=`sort -n $2 | awk ' { a[i++]=$1; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + if [ "$median" = "0" ]; then + median="0.01" + fi + local stddev=`awk ' { sqrsum += ($1 - '"$median"')^2; } END { print sqrt(sqrsum/NR); }' < $2` + local rss=`sort -n $2 | awk ' { a[i++]=$2; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + if [ "$basetime" = "" ]; then + basetime="$median" + fi + fi + local rmedian=`echo "scale=3; $median / $basetime" | bc` + local rstddev=`echo "scale=3; $rmedian * $stddev" | bc` + if [[ $median == Command* ]]; then + # echo "$1 NA NA NA NA (out of stack)" >> $3 + echo "$4 $5 $6 $7 NA 0.1 0 0.1" >> $3 + else + # echo "$1 ${median}s ${rmedian}x ${rstddev} ${rss}kb" >> $3 + echo "$4 $5 $6 $7 ${median} ${rmedian} ${rstddev} ${rss}" >> $3 + fi +} + +function avg_all { + local logbench="./log/avg.txt" + rm -f $logbench 2> /dev/null + for dir in $dirs; do + for runparam in $runparams; do + basetime="" + for bench in $benches; do + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local dbase=${base//\//_} + local bdir=$(echo $base | cut -d'/' -f 1) + local variant=${base#*\_} + local bname="${prefix}_${dbase}_${runparam}" + local log="./log/$bname.txt" + if [ "$dir" = "$bdir" ]; then + avg $bname $log $logbench $prefix $dir $variant $runparam + fi + done + echo "##" >> $logbench + done + echo "" >> $logbench + done + echo "" + echo "# benchmark elapsed relat. stddev rss" + column -t $logbench +} + +function graph_variant { # map + # $1 $2 $3 $4 $5 $6 $7 $8 $9 + # log entry: kk map trmc 1000 + awk ' + BEGIN { + prefix="'"$1"'" + bench="'"$2"'" + variant="'"$3"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $1==prefix && $2==bench && $3==variant { + if ($1 == "kk" && $3 == "trmc") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.2f}}\n", i++, $6, $7, $5 ); + } + else if ($6 == 0.1) { + printf( "%i 0.100 0.000 {\\!\\!out of stack}\n", i++); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($6>3 ? 3 : $6), $7, $6); + } + } + END { + print "}\\datatime" prefix bench variant + print " " + } + ' $4 >> $5 +} + +function graph_all { + local logbench="./log/avg.txt" + local texdata="./log/graph.tex" + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + #local benchname="" + #for bench in $benches; do + # local bbench=${bench#*\/} # no directory + # benchname=${bbench%\_*} + # break + #done + for runparam in $runparams; do + local lab="$runparam" + if [ "$lab" = "10000" ]; then + lab="10\\nsep 000" + elif [ "$lab" = "100000" ]; then + lab="100\\nsep 000" + elif [ "$lab" = "1000000" ]; then + lab="1\\nsep 000\\nsep 000" + fi + echo " \\strut $lab," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + for bench in $benches; do + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local bbench=${base#*\/} # no directory + local variant=${bbench#*\_} + local benchname=${bbench%\_*} + # echo "$benchname, $variant" + graph_variant $prefix $benchname $variant $logbench $texdata + done + cat $texdata +} + + +if [ "$do_build" = "yes" ]; then + build_all +fi + +if [ "$do_run" = "yes" ]; then + run_all +fi + +if [ "$do_avg" = "yes" ]; then + avg_all +fi + +if [ "$do_graph" = "yes" ]; then + graph_all +fi diff --git a/test/fip/src/finger/finger_fip.kk b/test/fip/src/finger/finger_fip.kk new file mode 100644 index 000000000..40da66ad9 --- /dev/null +++ b/test/fip/src/finger/finger_fip.kk @@ -0,0 +1,285 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +ref type pad + Pad + +type reuse3 + Reuse3(a : pad, b : pad, c : pad) + +type afew + One(a : a, b : pad, c : pad) + Two(a : a, b : a, c : pad) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a, c : pad) + Triple(a : a, b : a, c : a) + +type seq + Empty + Unit(a : a, b : pad, c : pad) + More0(l : a, s : seq>, r : afew) + More(l : tuple, s : seq>, r : afew) + +type buffer + BNil + BCons(next : buffer, b : pad, c : pad) + +value type bseq + BSeq(s : seq, q : buffer) + +// Isomorphic to (,,,) but unboxed +value type tuple4 + Tuple4(fst:a,snd:b,thd:c,field4:d) + +fun bhead(^bs : bseq) : exn a + match bs + BSeq(s, _) -> head(s) + +fun head(^s : seq) : exn a + match s + Unit(x) -> x + More0(x, _, _) -> x + More(Pair(x, _, _), _, _) -> x + More(Triple(x, _, _), _, _) -> x + +fip fun bcons(x : a, u3 : reuse3, bs : bseq) : exn bseq + match bs + BSeq(s, b) -> + val (s', b') = cons(x, u3, s, b) + BSeq(s', b') + +fip fun cons(x : a, u3 : reuse3, s : seq, b : buffer) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) + More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) + More(Pair(y, z, _), q, u) -> (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) + More(Triple(y, z, w), q, u) -> + match b + BCons(b', _, _) -> + val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') + (More(Pair(x, y, Pad), q', u), b'') + +fip fun buncons(bs : bseq) : exn (a, reuse3, bseq) + match bs + BSeq(s, b) -> + val Tuple4(x, u3, s', b') = uncons(s, b) + (x, u3, BSeq(s', b')) + +fip fun uncons(s : seq, b : buffer) : exn tuple4, buffer> + match s + Unit(x, _, _) -> Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) + More(Triple(x, y, z), q, u) -> + match b + BCons(b', _, _) -> Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') + More(Pair(x, y, _), q, u) -> Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) + More0(x, q, u) -> + val (q', b') = more0(q, u, b) + Tuple4(x, Reuse3(Pad,Pad,Pad), q', b') + +fip fun more0(q : seq>, u : afew, b : buffer) : (seq, buffer) + match q + Empty -> match u + One(x, y, z) -> (Unit(x, y, z), b) + Two(y, z, _) -> + match b + BCons(b', _, _) -> + (More0(y, Empty, One(z, Pad, Pad)), b') + Three(y, z, w) -> + match b + BCons(b', _, _) -> + (More0(y, Empty, Two(z, w, Pad)), b') + Unit(p, _, _) -> match p + Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) + Triple(x, y, z) -> + match b + BCons(b', _, _) -> + (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') + More0(p, q1, u1) -> match p + Pair(x, y) -> + val (q1', b') = more0(q1, u1, b) + (More(Pair(x, y, Pad), q1', u), b') + Triple(x, y, z) -> + match b + BCons(b', _, _) -> + (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') + More(Pair(p, y1), q1, u1) -> match p + Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) + Triple(x, y, z) -> + match b + BCons(b', _, _) -> + (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') + More(Triple(p, y1, z1), q1, u1) -> + match b + BCons(b', _, _) -> match p + Pair(x, y) -> (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') + Triple(x, y, z) -> (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') + +fip fun bsnoc(bs : bseq, u3 : reuse3, x : a) : exn bseq + match bs + BSeq(s, b) -> + val (s', b') = snoc(s, b, u3, x) + BSeq(s', b') + +fip fun snoc(s : seq, b : buffer, u3 : reuse3, x : a) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) + More0(u, q, One(y, _, _)) -> (More0(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More0(u, q, Two(y, z, _)) -> (More0(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More0(u, q, Three(y, z, w)) -> + match b + BCons(b', _, _) -> + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More0(u, q', Two(w, x, Pad)), b'') + More(u, q, One(y, _, _)) -> (More(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More(u, q, Two(y, z, _)) -> (More(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More(u, q, Three(y, z, w)) -> + match b + BCons(b', _, _) -> + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More(u, q', Two(w, x, Pad)), b'') + +// append + +type list3 + Cons3(x : a, xx : list3, c : pad) + Nil3 + +fip fun reverse3(xs : list3) : list3 + reverse-append3( xs, Nil3 ) + +fip fun reverse-acc(acc : list3, ys : list3 ) : list3 + match ys + Cons3(x,xx,pad) -> reverse-acc(Cons3(x,acc,pad),xx) + _ -> acc + +fip fun reverse-append3( xs : list3, tl : list3 ) : list3 + reverse-acc(tl,xs) + +fip fun (++)(xs : list3, ys : list3 ) : list3 + append3(xs, ys) + +fip fun append3(xs : list3, ys : list3 ) : list3 + match xs + Cons3(x,xx,pad) -> Cons3(x,append3(xx,ys),pad) + Nil3 -> ys + +fip fun foldl3(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(z1,z2,Reuse3(Pad,Pad,Pad),x) + foldl3(xx,z1',z2',f) + Nil3 -> (z1,z2) + +// foldl3 specialized to the `flip` function +fip fun foldl3_flipped(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(x,Reuse3(Pad,Pad,Pad),z1,z2) + foldl3_flipped(xx,z1',z2',f) + Nil3 -> (z1,z2) + +fip fun foldr3(xs,z1,z2,^f) + xs.reverse3.foldl3_flipped(z1,z2,f) + +fip fun (++)( xs : buffer, ys : buffer ) : buffer + append-buffers(xs, ys) + +fip fun append-buffers(b1 : buffer, b2 : buffer) : buffer + match b1 + BNil -> b2 + BCons(b', _, _) -> BCons(append-buffers(b', b2), Pad, Pad) + +fip fun afew-to-list(u : afew, b : buffer) : exn (list3, buffer) + match u + One(x) -> (Cons3(x, Nil3, Pad), b) + Two(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Three(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun tuple-to-list(u : tuple, b : buffer) : exn (list3, buffer) + match u + Pair(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Triple(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun to-tuples(xs : list3, b : buffer) : (list3>, buffer) + match xs + Cons3(x, Cons3(y, Nil3)) -> + (Cons3(Pair(x,y,Pad), Nil3, Pad), b) + Cons3(x, Cons3(y, Cons3(z, Cons3(w, Nil3)))) -> + (Cons3(Pair(x,y,Pad), Cons3(Pair(z,w,Pad),Nil3,Pad), Pad), b) + Cons3(x, Cons3(y, Cons3(z, xs))) -> + val (xs', b') = to-tuples(xs, b) + (Cons3(Triple(x,y,z), xs', Pad), BCons(b', Pad, Pad)) + _ -> (Nil3, b) // only if xs == Nil3 + +fip fun append(q1 : bseq, q2 : bseq) : pure bseq + match (q1, q2) + (BSeq(q1, b1), BSeq(q2, b2)) -> + val (q, b) = glue(q1, b1, Nil3, BNil, q2, b2) + BSeq(q, b) + +fip fun glue(q1 : seq, b1 : buffer, xs : list3, bs0 : buffer, q2 : seq, b2 : buffer) : pure (seq, buffer) + match(q1, q2) + (Empty, q2) -> xs.foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Empty) -> xs.foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (Unit(x,_,_), q2) -> (Cons3(x,xs,Pad)).foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Unit(x,_,_)) -> append3(xs,Cons3(x,Nil3,Pad)).foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + (More(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + +// benchmark + +fun iterate(s : bseq, n : int32) : bseq + if n <= 0.int32 then s + else + val (x, u3, s') = buncons(s) + iterate(bsnoc(s', u3, x), n - 1.int32) + +fun build(n : int32, s : bseq) : bseq + if n <= 0.int32 then s else build(n - 1.int32, bsnoc(s, Reuse3(Pad,Pad,Pad), n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, BSeq(Empty, BNil)) + acc + bhead(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/finger/finger_std.kk b/test/fip/src/finger/finger_std.kk new file mode 100644 index 000000000..bcfbfd7e8 --- /dev/null +++ b/test/fip/src/finger/finger_std.kk @@ -0,0 +1,112 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +// Originally "some" which is a reserved keyword in Koka +type afew + One(a : a) + Two(a : a, b : a) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a) + Triple(a : a, b : a, c : a) + +type seq + Empty // Nil is used for the empty list in Koka + Unit(a : a) + More(l : afew, s : seq>, r : afew) + +fun head(s : seq) : a + match s + Unit(x) -> x + More(One(x), _, _) -> x + More(Two(x, _), _, _) -> x + More(Three(x, _, _), _, _) -> x + +fun cons(x : a, s : seq) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(x), Empty, One(y)) + More(One(y), q, u) -> More(Two(x, y), q, u) + More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) + More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) + +fun uncons(s : seq) : (a, seq) + match s + Unit(x) -> (x, Empty) + More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) + More(Two(x, y), q, u) -> (x, More(One(y), q, u)) + More(One(x), q, u) -> (x, more0(q, u)) + +// we inline chop and map1 for better reuse behaviour +fun more0(q : seq>, u : afew) : seq + match q + Empty -> match u + One(y) -> Unit(y) + Two(y, z) -> More(One(y), Empty, One(z)) + Three(y, z, w) -> More(One(y), Empty, Two(z, w)) + Unit(p) -> match p + Pair(x, y) -> More(Two(x, y), Empty, u) + Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) + More(One(p), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) + Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) + More(Two(p, y1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) + More(Three(p, y1, z1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) + +fun snoc(s : seq, x : a) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(y), Empty, One(x)) + More(u, q, One(y)) -> More(u, q, Two(y, x)) + More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) + More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) + +fun to-list(u : afew) : list + match u + One(x) -> [x] + Two(x,y) -> [x,y] + Three(x,y,z) -> [x,y,z] + +fun to-tuples(xs : list) : list> + match xs + Cons(x, Cons(y, Nil)) -> [Pair(x,y)] + Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] + Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) + _ -> [] // only if xs == Nil + +fun append(q1 : seq, q2 : seq) :
seq + glue(q1, Nil, q2) + +fun glue(q1 : seq, xs : list, q2 : seq) :
seq + match(q1, q2) + (Empty, _) -> xs.foldr(q2, cons) + (_, Empty) -> xs.foldl(q1, snoc) + (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) + (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) + +fun iterate(s : seq, n : int32) : seq + if n <= 0.int32 then s + else + val (x, s') = uncons(s) + iterate(snoc(s', x), n - 1.int32) + +fun build(n : int32, s : seq) :
seq + if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, Empty) + acc + head(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs.c b/test/fip/src/rbtree/rbtree_clrs.c new file mode 100644 index 000000000..1a31ca7dc --- /dev/null +++ b/test/fip/src/rbtree/rbtree_clrs.c @@ -0,0 +1,183 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_full.c b/test/fip/src/rbtree/rbtree_clrs_full.c new file mode 100644 index 000000000..29cfe80b1 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_clrs_full.c @@ -0,0 +1,187 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein +// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + while(z->parent != T->nil) { + z = z->parent; + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c b/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c new file mode 100644 index 000000000..8b313bf04 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c @@ -0,0 +1,188 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein +// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. + +#include +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + while(z->parent != T->nil) { + z = z->parent; + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)mi_malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)mi_malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)mi_malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + mi_free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + mi_free(t->nil); + mi_free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_mimalloc.c b/test/fip/src/rbtree/rbtree_clrs_mimalloc.c new file mode 100644 index 000000000..6e7ffb208 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_clrs_mimalloc.c @@ -0,0 +1,184 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein + +#include +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)mi_malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)mi_malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)mi_malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + mi_free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + mi_free(t->nil); + mi_free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip.kk b/test/fip/src/rbtree/rbtree_fip.kk new file mode 100644 index 000000000..578fc521b --- /dev/null +++ b/test/fip/src/rbtree/rbtree_fip.kk @@ -0,0 +1,91 @@ +import std/num/int32 +import std/os/env + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf + +fip fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree + match t + Node(c, l, kx, vx, r) + -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) + elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) + else balance(z, Node(c, l, key, v, r)) + Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) + +fip fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + t -> t + +fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : tree ) : exn tree + match z + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) + else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) + Done -> Node(Black, l1, k1, v1, t) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) + else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) + Done -> Node(Black, t, k1, v1, r1) + z -> rebuild(z, t) + + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree_fip_noreuse.kk b/test/fip/src/rbtree/rbtree_fip_noreuse.kk new file mode 100644 index 000000000..578fc521b --- /dev/null +++ b/test/fip/src/rbtree/rbtree_fip_noreuse.kk @@ -0,0 +1,91 @@ +import std/num/int32 +import std/os/env + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf + +fip fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree + match t + Node(c, l, kx, vx, r) + -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) + elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) + else balance(z, Node(c, l, key, v, r)) + Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) + +fip fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + t -> t + +fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : tree ) : exn tree + match z + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) + else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) + Done -> Node(Black, l1, k1, v1, t) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) + else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) + Done -> Node(Black, t, k1, v1, r1) + z -> rebuild(z, t) + + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree_icfp.kk b/test/fip/src/rbtree/rbtree_icfp.kk new file mode 100644 index 000000000..c0db85f64 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_icfp.kk @@ -0,0 +1,77 @@ +import std/num/int32 +import std/os/env + +type any + Any + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type reuse5 + Reuse5(a : color, b : any, c : any, d : bool, e : any) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : reuse5 ) : tree + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Leaf, k, v, Leaf, Reuse5(Red,Any,Any,True,Any)) + +fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree_std.kk b/test/fip/src/rbtree/rbtree_std.kk new file mode 100644 index 000000000..f16c30227 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_std.kk @@ -0,0 +1,91 @@ +// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean +import std/num/int32 +import std/os/env + +type color + Red + Black + + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + + +fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + + +fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree + match l + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) + Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) + -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) + Node(_, lx, kx, vx, rx) + -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) + Leaf -> Leaf + + +fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree + match r + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) + Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) + Node(_, lx, kx, vx, rx) + -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) + Leaf -> Leaf + + +fun ins(t : tree, k : int32, v : bool) : tree + match t + Node(Red, l, kx, vx, r) + -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) + elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) + else Node(Red, l, k, v, r) + Node(Black, l, kx, vx, r) + -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) + else Node(Black, ins(l, k, v), kx, vx, r)) + elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) + else Node(Black, l, kx, vx, ins(r, k, v))) + else Node(Black, l, k, v, r) + Leaf -> Node(Red, Leaf, k, v, Leaf) + + +fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + _ -> t + + +fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v).set-black + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : div tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : div tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_std_noreuse.kk b/test/fip/src/rbtree/rbtree_std_noreuse.kk new file mode 100644 index 000000000..f16c30227 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_std_noreuse.kk @@ -0,0 +1,91 @@ +// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean +import std/num/int32 +import std/os/env + +type color + Red + Black + + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + + +fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + + +fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree + match l + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) + Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) + -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) + Node(_, lx, kx, vx, rx) + -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) + Leaf -> Leaf + + +fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree + match r + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) + Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) + Node(_, lx, kx, vx, rx) + -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) + Leaf -> Leaf + + +fun ins(t : tree, k : int32, v : bool) : tree + match t + Node(Red, l, kx, vx, r) + -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) + elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) + else Node(Red, l, k, v, r) + Node(Black, l, kx, vx, r) + -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) + else Node(Black, ins(l, k, v), kx, vx, r)) + elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) + else Node(Black, l, kx, vx, ins(r, k, v))) + else Node(Black, l, k, v, r) + Leaf -> Node(Red, Leaf, k, v, Leaf) + + +fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + _ -> t + + +fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v).set-black + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : div tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : div tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_merge_fip.kk b/test/fip/src/sort/sort_merge_fip.kk new file mode 100644 index 000000000..8fa7527a2 --- /dev/null +++ b/test/fip/src/sort/sort_merge_fip.kk @@ -0,0 +1,148 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +type unit2 + Unit2(a : pad, b : pad) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Singleton(c : sublist, z : partition) + Sublist(c : a, z : partition) + End + +fip fun reverse-go(c : sublist, acc : sublist, u : unit2) : sublist + match c + SCons(a, cs) -> reverse-go(cs, SCons(a, acc), u) + STuple(a, b) -> SCons(b, SCons(a, acc)) + +fip fun reverse-sublist(c : sublist) : sublist + match c + SCons(a, SCons(b, c)) -> reverse-go(c, STuple(b, a), Unit2(Pad,Pad)) + SCons(a, STuple(b, c)) -> SCons(c, STuple(b, a)) + STuple(a, b) -> STuple(b, a) + +fip fun to-list(c : sublist, u : unit2) : list + match c + SCons(a, cs) -> Cons(a, to-list(cs, u)) + STuple(a, b) -> Cons(a, Cons(b, Nil)) + +fip fun sequences(xs : list) : div partition + match(xs) + Cons(a, Cons(b, xs1)) -> + if(a > b) then descending(b, STuple(b, a), xs1, Unit2(Pad,Pad)) + else ascending(b, STuple(b, a), xs1, Unit2(Pad,Pad)) + Cons(a, Nil) -> Sublist(a, End) + Nil -> End + +fip fun descending(a : elem, sublist : sublist, bs : list, u : unit2) : div partition + match(bs) + Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1, u) + bs -> Singleton(sublist, sequences(bs)) + +fip fun ascending(a : elem, sublist : sublist, bs : list, u : unit2) : div partition + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1, u) + bs -> Singleton(reverse-sublist(sublist), sequences(bs)) + +fip fun merge-all(xs : partition) : div list + match(xs) + Singleton(x, End) -> to-list(x, Unit2(Pad,Pad)) + Sublist(x, End) -> Cons(x, Nil) + xs -> merge-all(merge-pairs(xs)) + +fip fun merge-pairs(xs : partition) :
partition + match(xs) + Singleton(a, Singleton(b, xs1)) -> Singleton(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Sublist(b, xs1)) -> Singleton(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Sublist(a, Singleton(b, xs1)) -> Singleton(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Sublist(a, Sublist(b, xs1)) -> + if a > b then Singleton(STuple(b, a), merge-pairs(xs1)) + else Singleton(STuple(a, b), merge-pairs(xs1)) + xs -> xs + +fip fun merge(c1 : sublist, c2 : sublist, u : unit2) : div sublist + match c1 + SCons(a, cs1) -> match c2 + SCons(b, cs2) -> if a > b then SCons(b, merge(SCons(a, cs1), cs2, u)) + else SCons(a, merge(cs1, SCons(b, cs2), u)) + STuple(b, c) -> merge-last2-left(SCons(a, cs1), b, c, u, Unit2(Pad,Pad)) + STuple(a, b) -> merge-last2-right(a, b, c2, u, Unit2(Pad,Pad)) + +fip fun merge-last2-right(a : elem, b : elem, c2 : sublist, u1 : unit2, u2 : unit2) : div sublist + match c2 + SCons(c, cs2) -> + if a > c then SCons(c, merge-last2-right(a, b, cs2, u1, u2)) + else SCons(a, merge-last-right(b, SCons(c, cs2), u1)) + STuple(c, d) -> + if a > c then + if a > d then SCons(c, SCons(d, STuple(a, b))) + elif b > d then SCons(c, SCons(a, STuple(d, b))) + else SCons(c, SCons(a, STuple(b, d))) + elif b > c then + if b > d then SCons(a, SCons(c, STuple(d, b))) + else SCons(a, SCons(c, STuple(b, d))) + else SCons(a, SCons(b, STuple(c, d))) + +fip fun merge-last-right(a : elem, c2 : sublist, u1 : unit2) : div sublist + match c2 + SCons(c, cs2) -> + if a > c then SCons(c, merge-last-right(a, cs2, u1)) + else SCons(a, SCons(c, cs2)) + STuple(b, c) -> + if a > b then + if a > c then SCons(b, STuple(c, a)) + else SCons(b, STuple(a, c)) + else SCons(a, STuple(b, c)) + +fip fun merge-last2-left(c2 : sublist, a : elem, b : elem, u1 : unit2, u2 : unit2) : div sublist + match c2 + SCons(c, cs2) -> + if a >= c then SCons(c, merge-last2-left(cs2, a, b, u1, u2)) + else SCons(a, merge-last-left(SCons(c, cs2), b, u1)) + STuple(c, d) -> + if a >= c then + if a >= d then SCons(c, SCons(d, STuple(a, b))) + elif b >= d then SCons(c, SCons(a, STuple(d, b))) + else SCons(c, SCons(a, STuple(b, d))) + elif b >= c then + if b >= d then SCons(a, SCons(c, STuple(d, b))) + else SCons(a, SCons(c, STuple(b, d))) + else SCons(a, SCons(b, STuple(c, d))) + +fip fun merge-last-left(c2 : sublist, a : elem, u1 : unit2) : div sublist + match c2 + SCons(c, cs2) -> + if a >= c then SCons(c, merge-last-left(cs2, a, u1)) + else SCons(a, SCons(c, cs2)) + STuple(b, c) -> + if a >= b then + if a >= c then SCons(b, STuple(c, a)) + else SCons(b, STuple(a, c)) + else SCons(a, STuple(b, c)) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/sort/sort_merge_std.kk b/test/fip/src/sort/sort_merge_std.kk new file mode 100644 index 000000000..9fcb70ca7 --- /dev/null +++ b/test/fip/src/sort/sort_merge_std.kk @@ -0,0 +1,58 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun sequences(xs : list) :
list> + match(xs) + Cons(a, Cons(b, xs1)) -> + if(a > b) then descending(b, Cons(a, Nil), xs1) + else ascending(b, Cons(a, Nil), xs1) + _ -> Cons(xs, Nil) + +fun descending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) + _ -> Cons(Cons(a, chain), sequences(bs)) + +fun ascending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) + _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) + +fun merge-all(xs : list>) :
list + match xs + Cons(x, Nil) -> x + _ -> merge-all(merge-pairs(xs)) + +fun merge-pairs(xs : list>) :
list> + match xs + Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) + _ -> xs + +fun merge(xs : list, ys : list) :
list + match(xs, ys) + (Cons(x, xx), Cons(y, yy)) -> + if(x > y) then Cons(y, merge(xs, yy)) + else Cons(x, merge(xx, ys)) + (Cons(_, _), Nil) -> xs + (_, _) -> ys + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_quick_fip.kk b/test/fip/src/sort/sort_quick_fip.kk new file mode 100644 index 000000000..ee117ba0d --- /dev/null +++ b/test/fip/src/sort/sort_quick_fip.kk @@ -0,0 +1,104 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +ref type unit2 + Unit2(a : pad, b : pad) + +type maybe2 + Nothing2 + Just2(a : a, b : pad) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Singleton(c : sublist, bdl : partition) + Sublist(c : a, bdl : partition) + End + +fip fun quicksort(xs : list) : div list + quicksort-go(xs, End) + +fip fun quicksort-go(xs : list, b : partition) : div list + match xs + Nil -> quicksort-app(b) + Cons(p, xx) -> + val (lo, hi) = split-list(p, xx, Done, b, Unit2(Pad,Pad)) + quicksort-go(lo, hi) + +fip fun quicksort-sublist(xs : sublist, bdl : partition, u : unit2) : div list + match xs + SCons(p, xx) -> + val (lo, hi) = split-sublist(p, xx, Done, bdl, u, Unit2(Pad,Pad)) + quicksort-go(lo, hi) + STuple(a, b) -> + if a <= b + then Cons(a, Cons(b, quicksort-app(bdl))) + else Cons(b, Cons(a, quicksort-app(bdl))) + +fip fun quicksort-app(bdl : partition) : div list + match bdl + End -> Nil + Sublist(p, b) -> Cons(p,quicksort-app(b)) + Singleton(c, b) -> quicksort-sublist(c, b, Unit2(Pad,Pad)) + +type accum + MkLo(x : a, k : accum) + MkHi(x : a, k : accum) + Done + +fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) + match xs + Nil -> split-app1(k, p, Nil, Nothing2, b, u) + Cons(x, xx) -> + if x < p + then split-list(p, xx, MkLo(x, k), b, u) + else split-list(p, xx, MkHi(x, k), b, u) + +fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) + match xs + STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) + SCons(x, xx) -> + if x < p + then split-sublist(p, xx, MkLo(x, k), b, u, u1) + else split-sublist(p, xx, MkHi(x, k), b, u, u1) + +fip fun split-app1(k : accum, p : elem, lo : list, hi : maybe2, b : partition, u : unit2) :
(list, partition) + match k + MkLo(x, k) -> split-app1(k, p, Cons(x, lo), hi, b, u) + MkHi(x, k) -> match hi + Nothing2 -> split-app1(k, p, lo, Just2(x, Pad), b, u) + Just2(y, _) -> split-app2(k, p, lo, STuple(x,y), b, u, Unit2(Pad,Pad)) + Done -> match hi + Just2(x, _) -> (lo, Sublist(p, Sublist(x, b))) + Nothing2 -> (lo, Sublist(p, b)) + +fip fun split-app2(k : accum, p : elem, lo : list, hi : sublist, b : partition, u : unit2, u1 : unit2) : (list, partition) + match k + MkLo(x, k) -> split-app2(k, p, Cons(x,lo), hi, b, u, u1) + MkHi(x, k) -> split-app2(k, p, lo, SCons(x,hi), b, u, u1) + Done -> (lo, Sublist(p, Singleton(hi, b))) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/sort/sort_quick_std.kk b/test/fip/src/sort/sort_quick_std.kk new file mode 100644 index 000000000..9c62aaf35 --- /dev/null +++ b/test/fip/src/sort/sort_quick_std.kk @@ -0,0 +1,40 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun quicksort(xs : list, res : list) : list + match(xs) + Cons(x, xx) -> + val (lo, hi) = partition(x, xx) + quicksort(lo, Cons(x, quicksort(hi, res))) + Nil -> res + +fun partition(^x : elem, ys : list) + match(ys) + Cons(y, yy) -> + if(y < x) then + val (lo, hi) = partition(x, yy) + (Cons(y, lo), hi) + else + val (lo, hi) = partition(x, yy) + (lo, Cons(y, hi)) + Nil -> (Nil, Nil) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs, Nil) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip.c b/test/fip/src/tmap/tmap_fip.c new file mode 100644 index 000000000..b30e2754d --- /dev/null +++ b/test/fip/src/tmap/tmap_fip.c @@ -0,0 +1,101 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t header; + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->header = 0; + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { + struct node* acc = NULL; + + acc: + while(root != NULL) { + struct node* acc_ = create_node(root->data); + acc_->left = acc; + acc_->right = root->right; + root = root->left; + acc = acc_; + } + + app: + if(acc == NULL) return root; + if(acc->header == 0) { + struct node* right = acc->right; + acc->header = 1; + acc->data = f(acc->data); + acc->right = acc->left; + acc->left = root; + root = right; + goto acc; + } else { // acc->header == 1 + struct node* acc_ = acc->right; + acc->right = root; + root = acc; + acc = acc_; + goto app; + } +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + x += sum_tree(tmap(xs, increment)); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip.kk b/test/fip/src/tmap/tmap_fip.kk new file mode 100644 index 000000000..861765715 --- /dev/null +++ b/test/fip/src/tmap/tmap_fip.kk @@ -0,0 +1,47 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32_go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) + +fun tsum32(t0 : tree) + tsum32_go(t0, 0.int32) + +type accum + Hole + BinR(k : accum, x : a, r : tree) + BinL(l : tree, x : b, k : accum) + +fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree + match t + Leaf -> tmap-app( k, f, Leaf ) + Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) + +fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree + match k0 + BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) + BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) + Hole -> t + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 + println("total: " ++ x.show) + + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/tmap/tmap_fip_mimalloc.c b/test/fip/src/tmap/tmap_fip_mimalloc.c new file mode 100644 index 000000000..2a8516b61 --- /dev/null +++ b/test/fip/src/tmap/tmap_fip_mimalloc.c @@ -0,0 +1,102 @@ +#include +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t header; + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)mi_malloc(sizeof(struct node)); + new_node->header = 0; + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + mi_free(root); + return n; +} + +struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { + struct node* acc = NULL; + + acc: + while(root != NULL) { + struct node* acc_ = create_node(root->data); + acc_->left = acc; + acc_->right = root->right; + root = root->left; + acc = acc_; + } + + app: + if(acc == NULL) return root; + if(acc->header == 0) { + struct node* right = acc->right; + acc->header = 1; + acc->data = f(acc->data); + acc->right = acc->left; + acc->left = root; + root = right; + goto acc; + } else { // acc->header == 1 + struct node* acc_ = acc->right; + acc->right = root; + root = acc; + acc = acc_; + goto app; + } +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + x += sum_tree(tmap(xs, increment)); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip_noreuse.kk b/test/fip/src/tmap/tmap_fip_noreuse.kk new file mode 100644 index 000000000..861765715 --- /dev/null +++ b/test/fip/src/tmap/tmap_fip_noreuse.kk @@ -0,0 +1,47 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32_go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) + +fun tsum32(t0 : tree) + tsum32_go(t0, 0.int32) + +type accum + Hole + BinR(k : accum, x : a, r : tree) + BinL(l : tree, x : b, k : accum) + +fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree + match t + Leaf -> tmap-app( k, f, Leaf ) + Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) + +fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree + match k0 + BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) + BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) + Hole -> t + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 + println("total: " ++ x.show) + + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/tmap/tmap_std.c b/test/fip/src/tmap/tmap_std.c new file mode 100644 index 000000000..520951f78 --- /dev/null +++ b/test/fip/src/tmap/tmap_std.c @@ -0,0 +1,82 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { + while(root != NULL) { + struct node* root_ = create_node(root->data); + tmap(root->left, f, &root_->left); + root_->data = f(root_->data); + *dest = root_; + dest = &root_->right; + root = root->right; + } + *dest = NULL; +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + struct node* ys; + tmap(xs, increment, &ys); + x += sum_tree(ys); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_std.kk b/test/fip/src/tmap/tmap_std.kk new file mode 100644 index 000000000..e41f79750 --- /dev/null +++ b/test/fip/src/tmap/tmap_std.kk @@ -0,0 +1,34 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun tmap-std( xs : tree, f : a -> e b ) : e tree + match xs + Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) + Leaf -> Leaf + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-std(fn(x) x.inc).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/tmap/tmap_std_mimalloc.c b/test/fip/src/tmap/tmap_std_mimalloc.c new file mode 100644 index 000000000..4428f4242 --- /dev/null +++ b/test/fip/src/tmap/tmap_std_mimalloc.c @@ -0,0 +1,83 @@ +#include +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)mi_malloc(sizeof(struct node)); + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + mi_free(root); + return n; +} + +void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { + while(root != NULL) { + struct node* root_ = create_node(root->data); + tmap(root->left, f, &root_->left); + root_->data = f(root_->data); + *dest = root_; + dest = &root_->right; + root = root->right; + } + *dest = NULL; +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + struct node* ys; + tmap(xs, increment, &ys); + x += sum_tree(ys); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_std_noreuse.kk b/test/fip/src/tmap/tmap_std_noreuse.kk new file mode 100644 index 000000000..e41f79750 --- /dev/null +++ b/test/fip/src/tmap/tmap_std_noreuse.kk @@ -0,0 +1,34 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun tmap-std( xs : tree, f : a -> e b ) : e tree + match xs + Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) + Leaf -> Leaf + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-std(fn(x) x.inc).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) From 8f0a67fa11b83df932554c738ff49a3dd884a218 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 3 May 2023 07:11:20 -0700 Subject: [PATCH 159/233] add better rbtree fip version --- test/fip/src/rbtree/rbtree_fip_icfp.kk | 82 ++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) create mode 100644 test/fip/src/rbtree/rbtree_fip_icfp.kk diff --git a/test/fip/src/rbtree/rbtree_fip_icfp.kk b/test/fip/src/rbtree/rbtree_fip_icfp.kk new file mode 100644 index 000000000..4a4f6644c --- /dev/null +++ b/test/fip/src/rbtree/rbtree_fip_icfp.kk @@ -0,0 +1,82 @@ +import std/num/int32 +import std/os/env + +type any + Any + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type reuse5 + Reuse5(a : color, b : any, c : any, d : bool, e : any) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : balance-node ) : tree + match t + Balance(_,l,k,v,r) -> + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Balance(Black,Leaf, k, v, Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) From 8844b2db566b1b715db9eb39270ac0b524be7796 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 3 May 2023 07:35:26 -0700 Subject: [PATCH 160/233] add c++ rbtree fip --- kklib/include/kklib.h | 2 +- test/fip/bench.sh | 2 +- test/fip/src/rbtree/rbtree_cpp.cpp | 64 ++++++++++++++++++++++ test/fip/src/rbtree/rbtree_fip.kk | 85 ++++++++++++++++++++++++++++++ 4 files changed, 151 insertions(+), 2 deletions(-) create mode 100644 test/fip/src/rbtree/rbtree_cpp.cpp diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 39d4fc9bf..5bf967609 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -562,7 +562,7 @@ static inline void kk_free_local(const void* p, kk_context_t* ctx) { #if defined(kk_malloc_usable_size) #define KK_HAS_MALLOC_COPY static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { - const size_t size = kk_malloc_usable_size(p); + const size_t size = kk_malloc_usable_size((void*)p); void* q = kk_malloc(kk_to_ssize_t(size), ctx); memcpy(q,p,size); return q; diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 88d8f4eb0..27d4ff447 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -148,7 +148,7 @@ while : ; do done function build_kk { # - local options="-O2 --no-debug --fstdalloc --cc=$ccomp --buildtag=bench $kkopts" + local options="-O2 --no-debug --cc=$ccomp --buildtag=bench $kkopts" if [[ "$1" == *"noreuse.kk"* ]]; then options="$options --fno-reuse" fi diff --git a/test/fip/src/rbtree/rbtree_cpp.cpp b/test/fip/src/rbtree/rbtree_cpp.cpp new file mode 100644 index 000000000..051fc2f10 --- /dev/null +++ b/test/fip/src/rbtree/rbtree_cpp.cpp @@ -0,0 +1,64 @@ +// Using standard STL to test the red-black tree in C++ +// In glibc++ this uses +// With the LLVM libc++ this uses +// In glibc this uses eventually: +// (Highly optimized in-place red-black tree using the low pointer bit to encode color information.) + +#include +#include +#include +using std::for_each; + +typedef int nat; + +struct nat_lt_fn { + bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; } +}; + +typedef std::map map; + +map mk_map(unsigned n) { + map m; + while (n > 0) { + --n; + m.insert(std::make_pair(nat(n), n%10 == 0)); + } + return m; +} + +nat fold(map const & m) { + nat r(0); + for_each(m.begin(), m.end(), [&](std::pair const & p) { if (p.second) r = r + nat(1); }); + return r; +} + +/* +int main(int argc, char ** argv) { + unsigned n = 4200000; + if (argc == 2) { + n = atoi(argv[1]); + } + map m = mk_map(n); + std::cout << fold(m) << "\n"; + return 0; +} +*/ + +void test(int n) { + int iter = 10000000 / (n <= 0 ? 1 : n); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + map m = mk_map(n); + acc += fold(m); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip.kk b/test/fip/src/rbtree/rbtree_fip.kk index 578fc521b..e21d0913d 100644 --- a/test/fip/src/rbtree/rbtree_fip.kk +++ b/test/fip/src/rbtree/rbtree_fip.kk @@ -1,6 +1,90 @@ import std/num/int32 import std/os/env +type any + Any + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type reuse5 + Reuse5(a : color, b : any, c : any, d : bool, e : any) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : balance-node ) : tree + match t + Balance(_,l,k,v,r) -> + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Balance(Black,Leaf, k, v, Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) + +/* +import std/num/int32 +import std/os/env + type color Red Black @@ -89,3 +173,4 @@ fun test(n : int32) fun main() val n = get-args().head("").parse-int.default(100).int32 test(n) +*/ \ No newline at end of file From d2d6fa726cbb263c9e47b661bbc43a453919c058 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 3 May 2023 07:53:28 -0700 Subject: [PATCH 161/233] add furter noreuse benchmarks --- test/fip/bench.sh | 4 +- test/fip/src/finger/finger_std_noreuse.kk | 112 ++++++++++++++++++++ test/fip/src/sort/sort_merge_std_noreuse.kk | 58 ++++++++++ test/fip/src/sort/sort_quick_std_noreuse.kk | 40 +++++++ 4 files changed, 212 insertions(+), 2 deletions(-) create mode 100644 test/fip/src/finger/finger_std_noreuse.kk create mode 100644 test/fip/src/sort/sort_merge_std_noreuse.kk create mode 100644 test/fip/src/sort/sort_quick_std_noreuse.kk diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 27d4ff447..0889bb4ba 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -9,8 +9,8 @@ benches_tmapkk="tmap/tmap_std.kk tmap/tmap_fip.kk tmap/tmap_std_noreuse.kk tmap/ benches_tmapc="tmap/tmap_std_mimalloc.c tmap/tmap_fip_mimalloc.c tmap/tmap_std.c tmap/tmap_fip.c" benches_rbtreekk="rbtree/rbtree_icfp.kk rbtree/rbtree_std.kk rbtree/rbtree_fip.kk rbtree/rbtree_std_noreuse.kk rbtree/rbtree_fip_noreuse.kk" benches_rbtreec="rbtree/rbtree_clrs_mimalloc.c rbtree/rbtree_clrs_full_mimalloc.c rbtree/rbtree_clrs.c rbtree/rbtree_clrs_full.c" -benches_sortkk="sort/sort_merge_std.kk sort/sort_merge_fip.kk sort/sort_quick_std.kk sort/sort_quick_fip.kk" -benches_fingerkk="finger/finger_std.kk finger/finger_fip.kk" +benches_sortkk="sort/sort_merge_std.kk sort/sort_merge_fip.kk sort/sort_quick_std.kk sort/sort_quick_fip.kk sort/sort_merge_std_noreuse.kk sort/sort_quick_std_noreuse.kk " +benches_fingerkk="finger/finger_std.kk finger/finger_fip.kk finger/finger_std_noreuse.kk" benches_all="$benches_tmapkk $benches_tmapc $benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk" # get this by running `stack path | grep local-install-root`` in the koka development directory diff --git a/test/fip/src/finger/finger_std_noreuse.kk b/test/fip/src/finger/finger_std_noreuse.kk new file mode 100644 index 000000000..bcfbfd7e8 --- /dev/null +++ b/test/fip/src/finger/finger_std_noreuse.kk @@ -0,0 +1,112 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +// Originally "some" which is a reserved keyword in Koka +type afew + One(a : a) + Two(a : a, b : a) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a) + Triple(a : a, b : a, c : a) + +type seq + Empty // Nil is used for the empty list in Koka + Unit(a : a) + More(l : afew, s : seq>, r : afew) + +fun head(s : seq) : a + match s + Unit(x) -> x + More(One(x), _, _) -> x + More(Two(x, _), _, _) -> x + More(Three(x, _, _), _, _) -> x + +fun cons(x : a, s : seq) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(x), Empty, One(y)) + More(One(y), q, u) -> More(Two(x, y), q, u) + More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) + More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) + +fun uncons(s : seq) : (a, seq) + match s + Unit(x) -> (x, Empty) + More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) + More(Two(x, y), q, u) -> (x, More(One(y), q, u)) + More(One(x), q, u) -> (x, more0(q, u)) + +// we inline chop and map1 for better reuse behaviour +fun more0(q : seq>, u : afew) : seq + match q + Empty -> match u + One(y) -> Unit(y) + Two(y, z) -> More(One(y), Empty, One(z)) + Three(y, z, w) -> More(One(y), Empty, Two(z, w)) + Unit(p) -> match p + Pair(x, y) -> More(Two(x, y), Empty, u) + Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) + More(One(p), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) + Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) + More(Two(p, y1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) + More(Three(p, y1, z1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) + +fun snoc(s : seq, x : a) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(y), Empty, One(x)) + More(u, q, One(y)) -> More(u, q, Two(y, x)) + More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) + More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) + +fun to-list(u : afew) : list + match u + One(x) -> [x] + Two(x,y) -> [x,y] + Three(x,y,z) -> [x,y,z] + +fun to-tuples(xs : list) : list> + match xs + Cons(x, Cons(y, Nil)) -> [Pair(x,y)] + Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] + Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) + _ -> [] // only if xs == Nil + +fun append(q1 : seq, q2 : seq) :
seq + glue(q1, Nil, q2) + +fun glue(q1 : seq, xs : list, q2 : seq) :
seq + match(q1, q2) + (Empty, _) -> xs.foldr(q2, cons) + (_, Empty) -> xs.foldl(q1, snoc) + (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) + (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) + +fun iterate(s : seq, n : int32) : seq + if n <= 0.int32 then s + else + val (x, s') = uncons(s) + iterate(snoc(s', x), n - 1.int32) + +fun build(n : int32, s : seq) :
seq + if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, Empty) + acc + head(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_merge_std_noreuse.kk b/test/fip/src/sort/sort_merge_std_noreuse.kk new file mode 100644 index 000000000..9fcb70ca7 --- /dev/null +++ b/test/fip/src/sort/sort_merge_std_noreuse.kk @@ -0,0 +1,58 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun sequences(xs : list) :
list> + match(xs) + Cons(a, Cons(b, xs1)) -> + if(a > b) then descending(b, Cons(a, Nil), xs1) + else ascending(b, Cons(a, Nil), xs1) + _ -> Cons(xs, Nil) + +fun descending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) + _ -> Cons(Cons(a, chain), sequences(bs)) + +fun ascending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) + _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) + +fun merge-all(xs : list>) :
list + match xs + Cons(x, Nil) -> x + _ -> merge-all(merge-pairs(xs)) + +fun merge-pairs(xs : list>) :
list> + match xs + Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) + _ -> xs + +fun merge(xs : list, ys : list) :
list + match(xs, ys) + (Cons(x, xx), Cons(y, yy)) -> + if(x > y) then Cons(y, merge(xs, yy)) + else Cons(x, merge(xx, ys)) + (Cons(_, _), Nil) -> xs + (_, _) -> ys + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_quick_std_noreuse.kk b/test/fip/src/sort/sort_quick_std_noreuse.kk new file mode 100644 index 000000000..9c62aaf35 --- /dev/null +++ b/test/fip/src/sort/sort_quick_std_noreuse.kk @@ -0,0 +1,40 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun quicksort(xs : list, res : list) : list + match(xs) + Cons(x, xx) -> + val (lo, hi) = partition(x, xx) + quicksort(lo, Cons(x, quicksort(hi, res))) + Nil -> res + +fun partition(^x : elem, ys : list) + match(ys) + Cons(y, yy) -> + if(y < x) then + val (lo, hi) = partition(x, yy) + (Cons(y, lo), hi) + else + val (lo, hi) = partition(x, yy) + (lo, Cons(y, hi)) + Nil -> (Nil, Nil) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs, Nil) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file From 16d09323363f6953fd3ab2e2cea4f4aeb43e630d Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 3 May 2023 08:57:48 -0700 Subject: [PATCH 162/233] small edits --- test/fip/src/rbtree/rbtree_cpp.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/fip/src/rbtree/rbtree_cpp.cpp b/test/fip/src/rbtree/rbtree_cpp.cpp index 051fc2f10..fbc9b5927 100644 --- a/test/fip/src/rbtree/rbtree_cpp.cpp +++ b/test/fip/src/rbtree/rbtree_cpp.cpp @@ -9,7 +9,7 @@ #include using std::for_each; -typedef int nat; +typedef int32_t nat; struct nat_lt_fn { bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; } From 5284bde504200127193902d820f9bb6e3e2635a7 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 5 May 2023 16:45:02 -0700 Subject: [PATCH 163/233] Small edits --- src/Backend/C/FromCore.hs | 2 +- src/Common/Syntax.hs | 18 +++++++++++------- src/Core/CheckFBIP.hs | 23 ++++++++++------------- src/Kind/Infer.hs | 2 +- src/Syntax/Parse.hs | 16 ++++++++++++---- 5 files changed, 35 insertions(+), 26 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index b7d326d47..408122ac5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1515,7 +1515,7 @@ genGuards result guards bindings = do docs <- mapM (genGuard bindings result) guards return (vcat docs) -genGuard :: Bindings -> Result -> Guard-> Asm Doc +genGuard :: Bindings -> Result -> Guard -> Asm Doc genGuard bindings result (Guard guard expr) = do let guardFree = freeLocals guard exprFree = freeLocals expr diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index d5d4e466b..0756a93f5 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -16,7 +16,7 @@ module Common.Syntax( Visibility(..) , DefSort(..), isDefFun, defFun, defFunEx, defSortShowFull , ParamInfo(..) , DefInline(..) - , Fip(..), fipIsTail, fipAlloc, noFip, isNoFip + , Fip(..), FipAlloc(..), fipIsTail, fipAlloc, noFip, isNoFip , Target(..), CTarget(..), JsTarget(..), isTargetC, isTargetJS, isTargetWasm , isPublic, isPrivate , DataDef(..) @@ -333,11 +333,14 @@ data Assoc = AssocNone {-------------------------------------------------------------------------- Fip --------------------------------------------------------------------------} -data Fip = Fip { fipAlloc_ :: Int } - | Fbip { fipAlloc_ :: Int, fipTail :: Bool } +data Fip = Fip { fipAlloc_ :: FipAlloc } + | Fbip { fipAlloc_ :: FipAlloc, fipTail :: Bool } | NoFip { fipTail :: Bool } deriving (Eq,Ord) +data FipAlloc = AllocAtMost Int | AllocFinitely + deriving (Eq,Ord) + noFip :: Fip noFip = NoFip False @@ -351,12 +354,12 @@ fipIsTail fip NoFip t -> t _ -> True -fipAlloc :: Fip -> Int +fipAlloc :: Fip -> FipAlloc fipAlloc fip = case fip of Fip n -> n Fbip n _ -> n - NoFip _ -> 0 + NoFip _ -> AllocAtMost (-1) instance Show Fip where @@ -365,8 +368,9 @@ instance Show Fip where Fbip n t -> showTail t ++ "fbip" ++ showN n NoFip t -> showTail t where - showN 0 = " " - showN n = "(" ++ show n ++ ") " + showN (AllocAtMost 0) = " " + showN (AllocAtMost n) = "(" ++ show n ++ ") " + showN AllocFinitely = "(n) " showTail True = "tail " showTail _ = " " diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 4f9c79fab..943788966 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -147,7 +147,7 @@ chkBranches scrutinees branches gamma2 <- joinContexts (map branchPatterns branches') outs writeOutput gamma2 withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ - withTailModBranches branches' $ -- also filter out pattern match errors + withTailModProduct branches' $ -- also filter out pattern match errors mapM_ chkScrutinee scrutinees where fromVar (Var tname _) = Just tname @@ -168,9 +168,9 @@ chkScrutinee expr = chkExpr expr chkBranch :: [ParamInfo] -> Branch -> Chk () chkBranch whichBorrowed (Branch pats guards) = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zipDefault Own whichBorrowed pats - out <- extractOutput $ - withBorrowed (S.map getName $ bv $ map snd borPats) $ - mapM_ chkGuard guards + outs <- withBorrowed (S.map getName $ bv $ map snd borPats) $ + mapM (extractOutput . chkGuard) guards + out <- joinContexts [] outs writeOutput =<< foldM (flip bindPattern) out (map snd ownPats) chkGuard :: Guard -> Chk () @@ -450,10 +450,11 @@ withNonTail :: Chk a -> Chk a withNonTail = withInput (\st -> st { isTailContext = False }) -withTailModBranches :: [Branch] -> Chk a -> Chk a -withTailModBranches [Branch _ [Guard test expr]] | isExprTrue test +-- | Tail modulo a pattern-match. This handles modulo product contexts. +withTailModProduct :: [Branch] -> Chk a -> Chk a +withTailModProduct [Branch _ [Guard test expr]] | isExprTrue test = withTailMod [expr] -withTailModBranches _ = withNonTail +withTailModProduct _ = withNonTail withTailMod :: [Expr] -> Chk a -> Chk a withTailMod modExpr @@ -470,10 +471,9 @@ isModCons expr Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModCons e App f args -> isModConsFun f && all isModCons args _ -> False - where - isModConsBranch (Branch pat guards) = all isModConsGuard guards - isModConsGuard (Guard test expr) = isModCons test && isModCons expr +-- | Functions with non-observable execution can be moved before the mod-cons call. +-- This is necessary for various casts introduced in the effect checker. isModConsFun :: Expr -> Bool isModConsFun expr = case expr of @@ -483,9 +483,6 @@ isModConsFun expr Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModConsFun e App f args -> hasTotalEffect (typeOf expr) && isModConsFun f && all isModCons args _ -> False - where - isModConsBranchFun (Branch pat guards) = all isModConsGuardFun guards - isModConsGuardFun (Guard test expr) = isModCons test && isModConsFun expr isModConsDef def = isModCons (defExpr def) diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 727622f71..0a59bbdd4 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -269,7 +269,7 @@ synTester info con branch2 = Branch (PatWild rc) [Guard guardTrue (Var nameFalse False rc)] patterns = [(Nothing,PatWild rc) | _ <- conInfoParams con] doc = "// Automatically generated. Tests for the `" ++ nameId (conInfoName con) ++ "` constructor of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (defFunEx [Borrow] (Fip 0)) InlineAlways doc)] + in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (defFunEx [Borrow] (Fip (AllocAtMost 0))) InlineAlways doc)] synConstrTag :: (ConInfo) -> DefGroup Type synConstrTag (con) diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index a442dd969..9e14b6377 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -1169,19 +1169,27 @@ pureDecl dvis -- valueDecl vrng vis <|> functionDecl vrng vis pdecl +parseFipAlloc :: LexParser FipAlloc +parseFipAlloc + = parens ( (do (num,_) <- integer + return (AllocAtMost (fromInteger num))) + <|> do _ <- specialId "n" + return AllocFinitely) + <|> return (AllocAtMost 0) + parseFip :: LexParser Fip parseFip = do isTail <- do specialId "tail" return True <|> return False ( do specialId "fip" - (n,_) <- parens integer <|> return (0,rangeNull) + alloc <- parseFipAlloc when isTail $ pwarningMessage "a 'fip' function implies already 'tail'" - return (Fip (fromInteger n)) + return (Fip alloc) <|> do specialId "fbip" - (n,_) <- parens integer <|> return (0,rangeNull) - return (Fbip (fromInteger n) isTail) + alloc <- parseFipAlloc + return (Fbip alloc isTail) <|> return (NoFip isTail)) functionDecl vrng vis From 8e648f2212cb9b67d385a15b35c73a70daa84daa Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 5 May 2023 16:45:38 -0700 Subject: [PATCH 164/233] Fix duplication of lazy bindings in guards --- src/Backend/C/FromCore.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 408122ac5..7f2e091f7 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1512,11 +1512,11 @@ genBranch result exprDocs doTest branch@(Branch patterns guards) genGuards :: Result -> [Guard] -> Bindings -> Asm Doc genGuards result guards bindings - = do docs <- mapM (genGuard bindings result) guards + = do (docs, _) <- foldM (genGuard result) ([], bindings) guards return (vcat docs) -genGuard :: Bindings -> Result -> Guard -> Asm Doc -genGuard bindings result (Guard guard expr) +genGuard :: Result -> ([Doc], Bindings) -> Guard -> Asm ([Doc], Bindings) +genGuard result (docs, bindings) (Guard guard expr) = do let guardFree = freeLocals guard exprFree = freeLocals expr (bindsGuard,bindsOther) = partition (\(name,_) -> tnamesMember name guardFree) bindings @@ -1525,11 +1525,11 @@ genGuard bindings result (Guard guard expr) case guard of Con tname repr | getName tname == nameTrue -> do doc <- genStat result expr - return (vcat (guardLocals ++ exprLocals ++ [doc])) + return (docs ++ [vcat (guardLocals ++ exprLocals ++ [doc])], bindsOther) _ -> do (gddoc,gdoc) <- genExpr guard sdoc <- genStat result expr - return (vcat $ guardLocals ++ gddoc ++ [text "if" <+> parensIf gdoc <+> - block (vcat (exprLocals ++ [sdoc]))]) + return (docs ++ [vcat $ guardLocals ++ gddoc ++ [text "if" <+> parensIf gdoc <+> + block (vcat (exprLocals ++ [sdoc]))]], bindsOther) parensIf :: Doc -> Doc -- avoid parens if already parenthesized parensIf d From 0a79481f642e799f7fab6856119784d9c9d3c8a6 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 5 May 2023 17:38:58 -0700 Subject: [PATCH 165/233] Add more fip annotations --- lib/std/core.kk | 154 +++++++++++++++++++++--------------------- lib/std/core/types.kk | 18 ++--- lib/std/num/int32.kk | 104 ++++++++++++++-------------- 3 files changed, 138 insertions(+), 138 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index 820a816f5..4c20119c9 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -687,110 +687,110 @@ pub fun any( xs : list, predicate : a -> e bool ) : e bool // Characters // ---------------------------------------------------------------------------- -pub inline extern (==) : (char,char) -> bool +pub inline fip extern (==) : (char,char) -> bool inline "(#1 == #2)" js inline "(#1 === #2)" -pub inline extern (!=) : (char,char) -> bool +pub inline fip extern (!=) : (char,char) -> bool inline "(#1 != #2)" js inline "(#1 !== #2)" -pub inline extern (<=) : (char,char) -> bool +pub inline fip extern (<=) : (char,char) -> bool inline "(#1 <= #2)" -pub inline extern (>=) : (char,char) -> bool +pub inline fip extern (>=) : (char,char) -> bool inline "(#1 >= #2)" -pub inline extern (<) : (char,char) -> bool +pub inline fip extern (<) : (char,char) -> bool inline "(#1 < #2)" -pub inline extern (>) : (char,char) -> bool +pub inline fip extern (>) : (char,char) -> bool inline "(#1 > #2)" -pub fun compare( x : char, y : char ) : order +pub fip fun compare( x : char, y : char ) : order if x < y then Lt elif x > y then Gt else Eq // Convert a character to its unicode code point -pub inline extern int : (char) -> int +pub inline fip extern int : (char) -> int inline "#1" c "kk_integer_from_int" cs inline "new BigInteger(#1)" // Convert a unicode code point to a character -pub inline extern char( i : int) : char +pub inline fip extern char( i : int) : char inline "(#1)" c "kk_integer_clamp32" cs inline "Primitive.IntToInt32(#1)" // Add two character code points -pub fun (+)(c : char, d : char) : total char +pub fip fun (+)(c : char, d : char) : total char (c.int + d.int).char // Substract two character codePoints -pub fun (-)(c : char, d : char) : total char +pub fip fun (-)(c : char, d : char) : total char (c.int - d.int).char // Is the character a lower-case ASCII character ? -pub fun is-lower( c : char ) : bool +pub fip fun is-lower( c : char ) : bool c >= 'a' && c <= 'z' // Is the character an upper-case ASCII character ? -pub fun is-upper( c : char ) : bool +pub fip fun is-upper( c : char ) : bool c >= 'A' && c <= 'Z' // Is the character an ASCII digit ? -pub fun is-digit( c : char ) : bool +pub fip fun is-digit( c : char ) : bool c >= '0' && c <= '9' // Is the character an ASCII hexa-decimal digit ? -pub fun is-hex-digit( c : char ) : bool +pub fip fun is-hex-digit( c : char ) : bool c.is-digit || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') // Is the character an ASCII letter is- -pub fun is-alpha( c : char ) : bool +pub fip fun is-alpha( c : char ) : bool c.is-lower || c.is-upper // Is the character ASCII letter or digit? -pub fun is-alpha-num( c : char ) : bool +pub fip fun is-alpha-num( c : char ) : bool c.is-alpha || c.is-digit // Is the character an ASCII character, e.g. `c <= '\x7F'` ? -pub fun is-ascii( c : char ) : bool +pub fip fun is-ascii( c : char ) : bool c <= '\x7F' // Is the character an ASCII control character, e.g. `c < ' '` ? -pub fun is-control( c : char ) : bool +pub fip fun is-control( c : char ) : bool c < ' ' // Tests if a character is an element of `" \t\n\r"` -pub fun is-white( c : char ) : bool +pub fip fun is-white( c : char ) : bool c == ' ' || c == '\t' || c == '\n' || c == '\r' // ---------------------------------------------------------------------------- // Booleans // ---------------------------------------------------------------------------- -pub fun (==)( x : bool, y : bool) : bool +pub fip fun (==)( x : bool, y : bool) : bool if x then y else !y -pub fun (!=)( x : bool, y : bool) : bool +pub fip fun (!=)( x : bool, y : bool) : bool if x then !y else y -pub fun (<)( x : bool, y : bool) : bool +pub fip fun (<)( x : bool, y : bool) : bool (!x && y) -pub fun (<=)( x : bool, y : bool) : bool +pub fip fun (<=)( x : bool, y : bool) : bool !(x > y) -pub fun (>)( x : bool, y : bool) : bool +pub fip fun (>)( x : bool, y : bool) : bool (x && !y) -pub fun (>=)( x : bool, y : bool) : bool +pub fip fun (>=)( x : bool, y : bool) : bool !(x < y) -pub fun compare( x : bool, y : bool) : order +pub fip fun compare( x : bool, y : bool) : order if x < y then Lt elif x > y then Gt else Eq @@ -1069,52 +1069,52 @@ pub fun fold-while-int( start : int, end : int, init : a, f : (int,a) -> e maybe // ---------------------------------------------------------------------------- // Convert an `:int32` to an `:int`. -pub inline extern int( i : int32 ) : int +pub inline fip extern int( i : int32 ) : int c "kk_integer_from_int" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" // Convert an integer to an `:int32`. The number is _clamped_ to the maximal or minimum `:int32` // value if it is outside the range of an `:int32`. -pub extern int32( i : int) : int32 +pub fip extern int32( i : int) : int32 c "kk_integer_clamp32" cs "Primitive.IntToInt32" js "$std_core._int_clamp32" // Convenient shorthand to `int32`, e.g. `1234.i32` -pub inline fun i32( i : int ) : int32 +pub inline fip fun i32( i : int ) : int32 i.int32 // Minimal set of operations that we need in `std/core`. -inline extern (<=) : (int32,int32) -> bool +inline fip extern (<=) : (int32,int32) -> bool inline "(#1 <= #2)" js inline "(#1 <= #2)" -inline extern (<) : (int32,int32) -> bool +inline fip extern (<) : (int32,int32) -> bool inline "(#1 < #2)" js inline "(#1 < #2)" -inline extern (+) : (int32,int32) -> int32 +inline fip extern (+) : (int32,int32) -> int32 inline "(#1 + #2)" js inline "((#1 + #2)|0)" -inline extern (-) : (int32,int32) -> int32 +inline fip extern (-) : (int32,int32) -> int32 inline "(#1 - #2)" js inline "((#1 - #2)|0)" -inline extern is-pos( i : int32 ) : bool +inline fip extern is-pos( i : int32 ) : bool inline "(#1>0)" -inline extern is-neg( i : int32 ) : bool +inline fip extern is-neg( i : int32 ) : bool inline "(#1<0)" -fun incr( i : int32 ) : int32 +fip fun incr( i : int32 ) : int32 i + 1.int32 -fun decr( i : int32 ) : int32 +fip fun decr( i : int32 ) : int32 i - 1.int32 // ---------------------------------------------------------------------------- @@ -1125,7 +1125,7 @@ fun decr( i : int32 ) : int32 // Convert an integer to an `:ssize_t`. The number is _clamped_ to the maximal or minimum `:ssize_t` // value if it is outside the range of an `:ssize_t`. -pub extern ssize_t( i : int) : ssize_t +pub fip extern ssize_t( i : int) : ssize_t c "kk_integer_clamp_ssize_t" cs "Primitive.IntToInt32" js "$std_core._int_clamp32" @@ -1137,37 +1137,37 @@ pub inline extern int( i : ssize_t ) : int js "$std_core._int_from_int32" // Minimal set of operations that we need in `std/core`. -inline extern (<=) : (ssize_t,ssize_t) -> bool +inline fip extern (<=) : (ssize_t,ssize_t) -> bool inline "(#1 <= #2)" -inline extern (>=) : (ssize_t,ssize_t) -> bool +inline fip extern (>=) : (ssize_t,ssize_t) -> bool inline "(#1 >= #2)" -inline extern (<) : (ssize_t,ssize_t) -> bool +inline fip extern (<) : (ssize_t,ssize_t) -> bool inline "(#1 < #2)" -inline extern (+) : (ssize_t,ssize_t) -> ssize_t +inline fip extern (+) : (ssize_t,ssize_t) -> ssize_t inline "(#1 + #2)" js inline "((#1 + #2)|0)" -inline extern (-) : (ssize_t,ssize_t) -> ssize_t +inline fip extern (-) : (ssize_t,ssize_t) -> ssize_t inline "(#1 - #2)" js inline "((#1 - #2)|0)" -inline extern is-pos( i : ssize_t ) : bool +inline fip extern is-pos( i : ssize_t ) : bool inline "(#1 > 0)" -inline extern is-neg( i : ssize_t ) : bool +inline fip extern is-neg( i : ssize_t ) : bool inline "(#1 < 0)" -extern is-zero( i : ssize_t ) : bool +fip extern is-zero( i : ssize_t ) : bool inline "(#1 == 0)" js inline "(#1 === 0)" -extern decr(i : ssize_t ) : ssize_t +fip extern decr(i : ssize_t ) : ssize_t inline "(#1 - 1)" -extern incr(i : ssize_t ) : ssize_t +fip extern incr(i : ssize_t ) : ssize_t inline "(#1 + 1)" @@ -1176,13 +1176,13 @@ extern incr(i : ssize_t ) : ssize_t // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int8`. -pub extern int8( i : int) : int8 +pub fip extern int8( i : int) : int8 c "kk_integer_clamp_int8" cs "Primitive.IntToInt8" js "$std_core._int_clamp8" // Convert an `:int8` to an `:int`. -pub inline extern int( i : int8 ) : int +pub inline fip extern int( i : int8 ) : int c "kk_integer_from_int8" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" @@ -1190,13 +1190,13 @@ pub inline extern int( i : int8 ) : int // clamp an `:int` to fit in an `:int8` but interpret the `:int` as an unsigned 8-bit value, // and clamp between 0 and 255. -pub extern uint8( i : int) : int8 +pub fip extern uint8( i : int) : int8 c "kk_integer_clamp_byte" cs "Primitive.IntToUInt8" js "$std_core._int_clamp_byte" // Convert an `:int8` to an `:int` but interpret the `:int8` as an unsigned 8-bit value between 0 and 255. -pub inline extern uint( i : int8 ) : int +pub inline fip extern uint( i : int8 ) : int c "kk_integer_from_uint8" cs inline "(new BigInteger(#1 >= 0 ? #1 : 256 + #1))" js "$std_core._int_from_int32" @@ -1207,13 +1207,13 @@ pub inline extern uint( i : int8 ) : int // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int16`. -pub extern int16( i : int) : int16 +pub fip extern int16( i : int) : int16 c "kk_integer_clamp_int16" cs "Primitive.IntToInt16" js "$std_core._int_clamp16" // Convert an `:int16` to an `:int`. -pub inline extern int( i : int16 ) : int +pub inline fip extern int( i : int16 ) : int c "kk_integer_from_int16" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" @@ -1224,7 +1224,7 @@ pub inline extern int( i : int16 ) : int // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int64_t`. -pub extern int64( i : int) : int64 +pub fip extern int64( i : int) : int64 c "kk_integer_clamp64" cs "Primitive.IntToInt64" js "$std_core._int_clamp64" @@ -1236,7 +1236,7 @@ pub inline extern int( i : int64 ) : int js "$std_core._int_from_int64" // Convenient shorthand to `int64`, e.g. `1234.i64` -pub inline fun i64( i : int ) : int64 +pub inline fip fun i64( i : int ) : int64 i.int64 @@ -1285,36 +1285,36 @@ extern xparse-int( s : string, hex : bool ) : maybe // todo: move to std/num/float64 // ---------------------------------------------------------------------------- -pub inline extern (==) : (float64,float64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (float64,float64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (<=) : (float64,float64) -> bool { inline "(#1 <= #2)" } -pub inline extern (>=) : (float64,float64) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (float64,float64) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (float64,float64) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (float64,float64) -> float64 { inline "(#1 + #2)" } -pub inline extern (-) : (float64,float64) -> float64 { inline "(#1 - #2)" } -pub inline extern (*) : (float64,float64) -> float64 { inline "(#1 * #2)" } -pub inline extern (/) : (float64,float64) -> float64 { inline "(#1 / #2)" } -pub inline extern (%) : (float64,float64) -> float64 { c inline "fmod(#1,#2)"; inline "(#1 % #2)" } +pub inline fip extern (==) : (float64,float64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (float64,float64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (<=) : (float64,float64) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (>=) : (float64,float64) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (float64,float64) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (float64,float64) -> bool { inline "(#1 > #2)" } +pub inline fip extern (+) : (float64,float64) -> float64 { inline "(#1 + #2)" } +pub inline fip extern (-) : (float64,float64) -> float64 { inline "(#1 - #2)" } +pub inline fip extern (*) : (float64,float64) -> float64 { inline "(#1 * #2)" } +pub inline fip extern (/) : (float64,float64) -> float64 { inline "(#1 / #2)" } +pub inline fip extern (%) : (float64,float64) -> float64 { c inline "fmod(#1,#2)"; inline "(#1 % #2)" } // Is the value negative? -pub fun is-neg( d : float64 ) : bool +pub fip fun is-neg( d : float64 ) : bool d < 0.0 // Is the value positive? -pub fun is-pos( d : float64 ) : bool +pub fip fun is-pos( d : float64 ) : bool d > 0.0 // Is the value zero? -pub fun is-zero( d : float64 ) : bool +pub fip fun is-zero( d : float64 ) : bool d == 0.0 -pub fun sign( d : float64 ) : order +pub fip fun sign( d : float64 ) : order if d < 0.0 then Lt elif d > 0.0 then Gt else Eq // Negate a `:float64`. -pub inline extern (~)( f : float64 ) : float64 +pub inline fip extern (~)( f : float64 ) : float64 inline "(-#1)" // inline so `~0.0` becomes negative zero // convert a `:float64` to an `:int` using `round` to round to its nearest integer. @@ -1326,23 +1326,23 @@ pub inline extern int( f : float64 ) : int js "$std_core._int_double" // Returns the value `f` raised to the power `p` . -pub inline extern (^)( f : float64, p : float64) : float64 +pub inline fip extern (^)( f : float64, p : float64) : float64 c inline "pow(#1,#2)" cs "Math.Pow" js "Math.pow" // Return the absolute value of a `:float64` `f` -pub inline extern abs( f : float64 ) : float64 +pub inline fip extern abs( f : float64 ) : float64 c inline "kk_double_abs(#1)" cs "Math.Abs" js "Math.abs" // Returns the smallest of two floats -pub fun min( x : float64, y : float64 ) : float64 +pub fip fun min( x : float64, y : float64 ) : float64 if x <= y then x else y // Returns the largest of two floats -pub fun max( x : float64, y : float64 ) : float64 +pub fip fun max( x : float64, y : float64 ) : float64 if x >= y then x else y // Returns the smallest element of a list of floats (or `0` for the empty list) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index cefcb35b4..b5529c884 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -187,7 +187,7 @@ pub fun hbox( x : a ) : hbox */ // Prevent inlining an expression by passing it to `keep` (which is a non-inlineable identity function) -pub noinline fun keep( x : a ) : a +pub noinline fip fun keep( x : a ) : a x // ---------------------------------------------------------------------------- @@ -195,27 +195,27 @@ pub noinline fun keep( x : a ) : a // ---------------------------------------------------------------------------- // The identity function returns its argument unchanged -pub fun id(x : a) : a +pub fip fun id(x : a) : a x // Logical conjuction -pub fun (&&)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation +pub fip fun (&&)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation if x then y else False // Logical disjunction -pub fun (||)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation +pub fip fun (||)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation if x then True else y // Logical negation -pub fun (!)( b : bool ) : bool +pub fip fun (!)( b : bool ) : bool if b then False else True // Logical negation -pub fun not( b : bool ) : bool +pub fip fun not( b : bool ) : bool if b then False else True // _Internal_: 32-bit zero, needed for markers in `std/core/hnd`. -pub inline extern zero32() : int32 +pub inline fip extern zero32() : int32 inline "0" // _Internal_: generated by type inference and later refined into one of the `open` variants in `std/core/hnd`. @@ -328,10 +328,10 @@ pub inline extern byref(loc : a) : a // ---------------------------------------------------------------------------- // _Unsafe_. Mark a function parameter as decreasing to suppress the non-termination effect (`:div`). -pub inline extern unsafe-decreasing( x : a ) : a +pub inline fip extern unsafe-decreasing( x : a ) : a inline "#1" -inline extern unsafe-total-cast : forall ( action : () -> e a ) -> (() -> a) +inline fip extern unsafe-total-cast : forall ( action : () -> e a ) -> (() -> a) inline "#1" // _Unsafe_. This function calls a function and pretends it did not have any effect at all. diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index da6ef52d6..9c4dc2ab4 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -35,12 +35,12 @@ pub inline extern int32( f : float64 ) : int32 */ // Convert an `:int32` to a boolean. -pub fun bool( i : int32 ) : bool +pub fip fun bool( i : int32 ) : bool (i!=zero) // Convert a boolean to an `:int32`. -pub fun int32( b : bool ) : int32 +pub fip fun int32( b : bool ) : int32 if (b) then one else zero @@ -75,31 +75,31 @@ pub fun show-hex32( i : int32, width : int = 8, use-capitals : bool = True, pre std/core/show-hex(i.uint,width,use-capitals,pre) -pub inline extern (==) : (int32,int32) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (int32,int32) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (<=) : (int32,int32) -> bool { inline "(#1 <= #2)" } -pub inline extern (>=) : (int32,int32) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (int32,int32) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (int32,int32) -> bool { inline "(#1 > #2)" } +pub inline fip extern (==) : (int32,int32) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (int32,int32) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (<=) : (int32,int32) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (>=) : (int32,int32) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (int32,int32) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (int32,int32) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (int32,int32) -> int32 +pub inline fip extern (+) : (int32,int32) -> int32 c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB js inline "((#1 + #2)|0)" -pub inline extern (-) : (int32,int32) -> int32 +pub inline fip extern (-) : (int32,int32) -> int32 c inline "(int32_t)((uint32_t)#1 - (uint32_t)#2)" // avoid UB js inline "((#1 - #2)|0)" -pub inline extern is-neg( i : int32 ) : bool +pub inline fip extern is-neg( i : int32 ) : bool inline "0 > #1" -pub inline extern is-pos( i : int32 ) : bool +pub inline fip extern is-pos( i : int32 ) : bool inline "0 < #1" -pub inline extern is-zero( i : int32 ) : bool +pub inline fip extern is-zero( i : int32 ) : bool inline "0 == #1" js inline "0 === #1" @@ -107,39 +107,39 @@ pub inline extern is-zero( i : int32 ) : bool pub val zero = 0.int32 pub val one = 1.int32 -pub fun sign( i : int32 ) : order +pub fip fun sign( i : int32 ) : order if (i.is-pos) then Gt elif (i.is-neg) then Lt else Eq // Returns `true` if the integer `i` is an odd number. -pub fun is-odd( i : int32 ) : bool +pub fip fun is-odd( i : int32 ) : bool and(i,1.int32) == 1.int32 // Returns `true` if the integer `i` is an even number. -pub fun is-even( i : int32 ) : bool +pub fip fun is-even( i : int32 ) : bool and(i,1.int32) == 0.int32 // Increment a 32-bit integer. -pub fun inc( i : int32 ) : int32 +pub fip fun inc( i : int32 ) : int32 i + 1.int32 // Decrement a 32-bit integer. -pub fun dec( i : int32 ) : int32 +pub fip fun dec( i : int32 ) : int32 i - 1.int32 // Multiply two 32-bit integers. -pub inline extern (*) : (int32,int32) -> int32 +pub inline fip extern (*) : (int32,int32) -> int32 inline "(int32_t)((uint32_t)#1 * (uint32_t)#2)" // avoid UB js "$std_core._int32_multiply" -pub fun compare( x : int32, y : int32) : order +pub fip fun compare( x : int32, y : int32) : order if (x < y) then Lt elif (x > y) then Gt else Eq @@ -148,7 +148,7 @@ pub fun compare( x : int32, y : int32) : order // Return the absolute value of an integer. // Raises an exception if the `:int32` is `min-int32` // (since the negation of `min-int32` equals itself and is still negative) -pub fun abs( i : int32 ) : exn int32 +pub fip fun abs( i : int32 ) : exn int32 if (!i.is-neg) then i elif (i > min-int32) then negate(i) else throw( "std/num/int32/abs: cannot make min-int32 into a positive int32 without overflow" ) @@ -157,7 +157,7 @@ pub fun abs( i : int32 ) : exn int32 // Return the absolute value of an integer. // Returns 0 if the `:int32` is `min-int32` // (since the negation of `min-int32` equals itself and is still negative) -pub fun abs0( i : int32 ) : int32 +pub fip fun abs0( i : int32 ) : int32 if (!i.is-neg) then i elif (i > min-int32) then negate(i) else 0.int32 @@ -165,129 +165,129 @@ pub fun abs0( i : int32 ) : int32 // Take the bitwise _and_ of two `:int32`s -pub inline extern and : (int32,int32) -> int32 +pub inline fip extern and : (int32,int32) -> int32 inline "(#1 & #2)"; // Take the bitwise _or_ of two `:int32`s -pub inline extern or : (int32,int32) -> int32 +pub inline fip extern or : (int32,int32) -> int32 inline "(#1 | #2)"; // Take the bitwise _xor_ of two `:int32`s -pub inline extern xor : (int32,int32) -> int32 +pub inline fip extern xor : (int32,int32) -> int32 inline "(#1 ^ #2)"; // Take the bitwise _xor_ of two `:int32`s -pub fun(^)( x : int32, y : int32) : int32 +pub fip fun(^)( x : int32, y : int32) : int32 xor(x,y) // Bitwise _not_ of an `:int32`, i.e. flips all bits. -pub inline extern not : ( i : int32 ) -> int32 +pub inline fip extern not : ( i : int32 ) -> int32 inline "(~#1)" // Shift an `:int32` `i` to the left by `n & 31` bits. -inline extern shl32 : (int32,int32) -> int32 +inline fip extern shl32 : (int32,int32) -> int32 c inline "kk_shl32(#1,#2)" js inline "#1 << #2" // javascript masks the shift already // Shift an `:int32` `i` to the left by `n & 31` bits. -pub fun shl( i : int32, shift : int ) : int32 +pub fip fun shl( i : int32, shift : int ) : int32 shl32( i, shift.int32 ) // Logical shift an `:int32` to the right by `n % 32` bits. Shift in zeros from the left. -inline extern shr32 : (int32,int32) -> int32 +inline fip extern shr32 : (int32,int32) -> int32 c inline "(int32_t)kk_shr32(#1,#2)" cs inline "(Int32)(((UInt32)#1)>>#2)" js inline "#1 >>> #2" // Logical shift an `:int32` to the right by `n % 32` bits. Shift in zeros from the left. -pub fun shr( i : int32, shift : int ) : int32 +pub fip fun shr( i : int32, shift : int ) : int32 shr32( i, shift.int32 ) // Arithmetic shift an `:int32` to the right by `n % 32` bits. Shifts in the sign bit from the left. -inline extern sar32 : (int32,int32) -> int32 +inline fip extern sar32 : (int32,int32) -> int32 c inline "kk_sar32(#1,#2)" cs inline "(#1>>#2)" js inline "#1 >> #2" // Arithmetic shift an `:int32` to the right by `n % 32` bits. Shifts in the sign bit from the left. -pub fun sar( i : int32, shift : int ) : int32 +pub fip fun sar( i : int32, shift : int ) : int32 sar32( i, shift.int32 ) // Bitwise rotate an `:int32` `n % 32` bits to the left. -inline extern rotl32( i : int32, n : int32 ) : int32 +inline fip extern rotl32( i : int32, n : int32 ) : int32 c inline "(int32_t)kk_bits_rotl32(#1,#2)" js "$std_core._int32_rotl" // Bitwise rotate an `:int32` `n % 32` bits to the left. -pub fun rotl( i : int32, shift : int ) : int32 +pub fip fun rotl( i : int32, shift : int ) : int32 rotl32( i, shift.int32 ) // Bitwise rotate an `:int32` `n % 32` bits to the right. -inline extern rotr32( i : int32, n : int32 ) : int32 +inline fip extern rotr32( i : int32, n : int32 ) : int32 c inline "(int32_t)kk_bits_rotr32(#1,#2)" js "$std_core._int32_rotr" // Bitwise rotate an `:int32` `n % 32` bits to the right. -pub fun rotr( i : int32, shift : int ) : int32 +pub fip fun rotr( i : int32, shift : int ) : int32 rotr32( i, shift.int32 ) // Return the minimum of two integers -pub fun min( i : int32, j : int32 ) : int32 +pub fip fun min( i : int32, j : int32 ) : int32 if (i <= j) then i else j // Return the maximum of two integers -pub fun max( i : int32, j : int32 ) : int32 +pub fip fun max( i : int32, j : int32 ) : int32 if (i >= j) then i else j // Truncated division (as in C). See also `(/):(x : int32, y : int32) -> int32`. -pub fun cdiv(i:int32, j:int32) : exn int32 +pub fip fun cdiv(i:int32, j:int32) : exn int32 if (j.is-zero) then throw("std/num/int32/cdiv: modulus by zero") elif (j == -1.int32 && i==min-int32) then throw("std/num/int32/cdiv: modulus overflow in cdiv(min-int32, -1.int32)") else unsafe-cdiv(i,j) // Truncated modulus (as in C). See also `(%):(x : int32, y : int32) -> int32`. -pub fun cmod(i:int32, j:int32) : exn int32 +pub fip fun cmod(i:int32, j:int32) : exn int32 if (j.is-zero) then throw("std/num/int32/cmod: modulus by zero") elif (j == -1.int32 && i==min-int32) then throw("std/num/int32/cmod: modulus overflow in cmod(min-int32, -1.int32)") else unsafe-cmod(i,j) // Truncated division (as in C). See also `(/):(x : int32, y : int32) -> int32`. -pub inline extern unsafe-cdiv : (int32,int32) -> int32 +pub inline fip extern unsafe-cdiv : (int32,int32) -> int32 inline "(#1 / #2)" js inline "((#1/#2)|0)" // Truncated modulus (as in C). See also `(%):(x : int32, y : int32) -> int32`. -pub inline extern unsafe-cmod : (int32,int32) -> int32 +pub inline fip extern unsafe-cmod : (int32,int32) -> int32 inline "(#1 % #2)" js inline "((#1 % #2)|0)" // Convert an 32-bit integer to a float64. -pub inline extern float64( i : int32) : float64 +pub inline fip extern float64( i : int32) : float64 c inline "(double)(#1)" cs inline "(double)(#1)" js inline "(#1)" // Negate a 32-bit integer -pub fun negate( i : int32 ) : int32 +pub fip fun negate( i : int32 ) : int32 (0.int32 - i) // Negate an 32-bit integer -pub fun (~)(i : int32) : total int32 +pub fip fun (~)(i : int32) : total int32 (0.int32 - i) @@ -314,7 +314,7 @@ Of course `(min-int32 + 1) / -1` is again positive (namely `max-int32`). See also _Division and modulus for computer scientists, Daan Leijen, 2001_ [pdf](http://research.microsoft.com/pubs/151917/divmodnote.pdf) . */ -pub fun (/)( x : int32, y : int32 ) : int32 +pub fip fun (/)( x : int32, y : int32 ) : int32 if (y == 0.int32) then return 0.int32 if (y == -1.int32 && x==min-int32) return x val q = unsafe-cdiv(x,y) @@ -325,7 +325,7 @@ pub fun (/)( x : int32, y : int32 ) : int32 // Euclidean-0 modulus. See `(/):(x : int32, y : int32) -> int32` division for more information. -pub fun (%)( x : int32, y : int32 ) : int32 +pub fip fun (%)( x : int32, y : int32 ) : int32 if (y == 0.int32) then return x if (y == -1.int32 && x==min-int32) return 0.int32 val r = unsafe-cmod(x,y) @@ -334,7 +334,7 @@ pub fun (%)( x : int32, y : int32 ) : int32 else (r - y) -pub fun divmod(x:int32,y:int32) : (int32,int32) +pub fip fun divmod(x:int32,y:int32) : (int32,int32) if (y.is-zero) then return (zero,x) if (y == -1.int32 && x==min-int32) return (x,0.int32) val q = unsafe-cdiv(x,y) @@ -344,7 +344,7 @@ pub fun divmod(x:int32,y:int32) : (int32,int32) else (q.inc,r - y) -pub fun fold-int32( start : int32, end : int32, init : a, f : (int32,a) -> e a ) : e a +pub fip fun fold-int32( start : int32, end : int32, init : a, ^f : (int32,a) -> e a ) : e a if (start >= end) then init else val x = f(start,init) fold-int32(unsafe-decreasing(start.inc), end, x, f) @@ -383,11 +383,11 @@ pub fun list32( lo: int32, hi: int32 ) : total list then Cons( lo, list32( unsafe-decreasing(lo.inc), hi ) ) else Nil -pub fun sum32( xs : list ) : int32 +pub fip fun sum32( ^xs : list ) : int32 // xs.foldl( 0.int32, fn(x,y) x + y ) sumacc32(xs,0.int32) -fun sumacc32( xs : list, acc : int32 ) : int32 +fip fun sumacc32( ^xs : list, acc : int32 ) : int32 match xs Cons(x,xx) -> sumacc32(xx,acc+x) Nil -> acc From 865ab9367a2776c8f41fb4d835d1693ef8e6e093 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 5 May 2023 17:46:01 -0700 Subject: [PATCH 166/233] Simplify examples (no significant perf change) --- test/fip/bench.sh | 1 - test/fip/src/finger/finger_fip.kk | 140 +++++++++++++------------- test/fip/src/sort/sort_merge_fip.kk | 147 +++++++++++++--------------- test/fip/src/sort/sort_quick_fip.kk | 61 +++++------- 4 files changed, 162 insertions(+), 187 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 0889bb4ba..293a13ee9 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -1,5 +1,4 @@ - # list sizes runparams="1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" diff --git a/test/fip/src/finger/finger_fip.kk b/test/fip/src/finger/finger_fip.kk index 40da66ad9..be025f0a0 100644 --- a/test/fip/src/finger/finger_fip.kk +++ b/test/fip/src/finger/finger_fip.kk @@ -46,102 +46,100 @@ fun head(^s : seq) : exn a More(Triple(x, _, _), _, _) -> x fip fun bcons(x : a, u3 : reuse3, bs : bseq) : exn bseq - match bs - BSeq(s, b) -> - val (s', b') = cons(x, u3, s, b) - BSeq(s', b') + val BSeq(s, b) = bs + val (s', b') = cons(x, u3, s, b) + BSeq(s', b') fip fun cons(x : a, u3 : reuse3, s : seq, b : buffer) : exn (seq, buffer) match s - Empty -> (Unit(x, Pad, Pad), b) - Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) - More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) - More(Pair(y, z, _), q, u) -> (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) + More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) + More(Pair(y, z, _), q, u) -> + (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) More(Triple(y, z, w), q, u) -> - match b - BCons(b', _, _) -> - val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') - (More(Pair(x, y, Pad), q', u), b'') + val BCons(b', _, _) = b + val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') + (More(Pair(x, y, Pad), q', u), b'') fip fun buncons(bs : bseq) : exn (a, reuse3, bseq) - match bs - BSeq(s, b) -> - val Tuple4(x, u3, s', b') = uncons(s, b) - (x, u3, BSeq(s', b')) + val BSeq(s, b) = bs + val Tuple4(x, u3, s', b') = uncons(s, b) + (x, u3, BSeq(s', b')) fip fun uncons(s : seq, b : buffer) : exn tuple4, buffer> match s - Unit(x, _, _) -> Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) + Unit(x, _, _) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) More(Triple(x, y, z), q, u) -> - match b - BCons(b', _, _) -> Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') - More(Pair(x, y, _), q, u) -> Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) + val BCons(b', _, _) = b + Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') + More(Pair(x, y, _), q, u) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) More0(x, q, u) -> val (q', b') = more0(q, u, b) Tuple4(x, Reuse3(Pad,Pad,Pad), q', b') -fip fun more0(q : seq>, u : afew, b : buffer) : (seq, buffer) +fip fun more0(q : seq>, u : afew, b : buffer) : exn (seq, buffer) match q - Empty -> match u - One(x, y, z) -> (Unit(x, y, z), b) - Two(y, z, _) -> - match b - BCons(b', _, _) -> - (More0(y, Empty, One(z, Pad, Pad)), b') - Three(y, z, w) -> - match b - BCons(b', _, _) -> - (More0(y, Empty, Two(z, w, Pad)), b') - Unit(p, _, _) -> match p - Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) - Triple(x, y, z) -> - match b - BCons(b', _, _) -> - (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') - More0(p, q1, u1) -> match p - Pair(x, y) -> - val (q1', b') = more0(q1, u1, b) - (More(Pair(x, y, Pad), q1', u), b') - Triple(x, y, z) -> - match b - BCons(b', _, _) -> - (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') - More(Pair(p, y1), q1, u1) -> match p - Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) - Triple(x, y, z) -> - match b - BCons(b', _, _) -> - (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') + Empty -> + match u + One(x, y, z) -> (Unit(x, y, z), b) + Two(y, z, _) -> + val BCons(b', _, _) = b + (More0(y, Empty, One(z, Pad, Pad)), b') + Three(y, z, w) -> + val BCons(b', _, _) = b + (More0(y, Empty, Two(z, w, Pad)), b') + Unit(p, _, _) -> + match p + Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') + More0(p, q1, u1) -> + match p + Pair(x, y) -> + val (q1', b') = more0(q1, u1, b) + (More(Pair(x, y, Pad), q1', u), b') + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') + More(Pair(p, y1), q1, u1) -> + match p + Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') More(Triple(p, y1, z1), q1, u1) -> - match b - BCons(b', _, _) -> match p - Pair(x, y) -> (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') - Triple(x, y, z) -> (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') + val BCons(b', _, _) = b + match p + Pair(x, y) -> + (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') + Triple(x, y, z) -> + (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') fip fun bsnoc(bs : bseq, u3 : reuse3, x : a) : exn bseq - match bs - BSeq(s, b) -> - val (s', b') = snoc(s, b, u3, x) - BSeq(s', b') + val BSeq(s, b) = bs + val (s', b') = snoc(s, b, u3, x) + BSeq(s', b') fip fun snoc(s : seq, b : buffer, u3 : reuse3, x : a) : exn (seq, buffer) match s - Empty -> (Unit(x, Pad, Pad), b) - Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) More0(u, q, One(y, _, _)) -> (More0(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More (u, q, One(y, _, _)) -> (More (u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) More0(u, q, Two(y, z, _)) -> (More0(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More (u, q, Two(y, z, _)) -> (More (u, q, Three(y, z, x)), BCons(b, Pad, Pad)) More0(u, q, Three(y, z, w)) -> - match b - BCons(b', _, _) -> - val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) - (More0(u, q', Two(w, x, Pad)), b'') - More(u, q, One(y, _, _)) -> (More(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) - More(u, q, Two(y, z, _)) -> (More(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More0(u, q', Two(w, x, Pad)), b'') More(u, q, Three(y, z, w)) -> - match b - BCons(b', _, _) -> - val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) - (More(u, q', Two(w, x, Pad)), b'') + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More(u, q', Two(w, x, Pad)), b'') // append diff --git a/test/fip/src/sort/sort_merge_fip.kk b/test/fip/src/sort/sort_merge_fip.kk index 8fa7527a2..8b0f077b7 100644 --- a/test/fip/src/sort/sort_merge_fip.kk +++ b/test/fip/src/sort/sort_merge_fip.kk @@ -10,13 +10,16 @@ ref type pad type unit2 Unit2(a : pad, b : pad) +type pair + Pair(a : a, b : a) + type sublist SCons(a : a, cs : sublist) STuple(a : a, b : a) type partition - Singleton(c : sublist, z : partition) - Sublist(c : a, z : partition) + Sublist(c : sublist, z : partition) + Singleton(c : a, z : partition) End fip fun reverse-go(c : sublist, acc : sublist, u : unit2) : sublist @@ -30,104 +33,86 @@ fip fun reverse-sublist(c : sublist) : sublist SCons(a, STuple(b, c)) -> SCons(c, STuple(b, a)) STuple(a, b) -> STuple(b, a) -fip fun to-list(c : sublist, u : unit2) : list - match c - SCons(a, cs) -> Cons(a, to-list(cs, u)) - STuple(a, b) -> Cons(a, Cons(b, Nil)) - fip fun sequences(xs : list) : div partition match(xs) - Cons(a, Cons(b, xs1)) -> - if(a > b) then descending(b, STuple(b, a), xs1, Unit2(Pad,Pad)) - else ascending(b, STuple(b, a), xs1, Unit2(Pad,Pad)) - Cons(a, Nil) -> Sublist(a, End) + Cons(a, Cons(b, xs1)) -> if(a > b) + then + val (sublist, bs) = descending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + else + val (sublist, bs) = ascending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + Cons(a, Nil) -> Singleton(a, End) Nil -> End -fip fun descending(a : elem, sublist : sublist, bs : list, u : unit2) : div partition +fip fun descending(a : elem, sublist : sublist, bs : list) : (sublist, list) match(bs) - Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1, u) - bs -> Singleton(sublist, sequences(bs)) + Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1) + bs -> (sublist, bs) -fip fun ascending(a : elem, sublist : sublist, bs : list, u : unit2) : div partition +fip fun ascending(a : elem, sublist : sublist, bs : list) : (sublist, list) match(bs) - Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1, u) - bs -> Singleton(reverse-sublist(sublist), sequences(bs)) + Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1) + bs -> (reverse-sublist(sublist), bs) -fip fun merge-all(xs : partition) : div list +fip fun to-list(c : sublist, u : unit2) : list + match c + SCons(a, cs) -> Cons(a, to-list(cs, u)) + STuple(a, b) -> Cons(a, Cons(b, Nil)) + +fip fun merge-all(xs : partition) :
list match(xs) - Singleton(x, End) -> to-list(x, Unit2(Pad,Pad)) - Sublist(x, End) -> Cons(x, Nil) + Sublist(x, End) -> to-list(x, Unit2(Pad,Pad)) + Singleton(x, End) -> Cons(x, Nil) xs -> merge-all(merge-pairs(xs)) fip fun merge-pairs(xs : partition) :
partition match(xs) - Singleton(a, Singleton(b, xs1)) -> Singleton(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Singleton(a, Sublist(b, xs1)) -> Singleton(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Sublist(a, Singleton(b, xs1)) -> Singleton(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Sublist(a, Sublist(b, xs1)) -> - if a > b then Singleton(STuple(b, a), merge-pairs(xs1)) - else Singleton(STuple(a, b), merge-pairs(xs1)) + Sublist(a, Sublist(b, xs1)) -> Sublist(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Sublist(a, Singleton(b, xs1)) -> Sublist(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Sublist(b, xs1)) -> Sublist(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Singleton(b, xs1)) -> + Sublist(if a <= b then STuple(a, b) else STuple(b, a), merge-pairs(xs1)) xs -> xs -fip fun merge(c1 : sublist, c2 : sublist, u : unit2) : div sublist +fip fun merge(c1 : sublist, c2 : sublist, u : unit2) :
sublist match c1 SCons(a, cs1) -> match c2 - SCons(b, cs2) -> if a > b then SCons(b, merge(SCons(a, cs1), cs2, u)) - else SCons(a, merge(cs1, SCons(b, cs2), u)) - STuple(b, c) -> merge-last2-left(SCons(a, cs1), b, c, u, Unit2(Pad,Pad)) - STuple(a, b) -> merge-last2-right(a, b, c2, u, Unit2(Pad,Pad)) - -fip fun merge-last2-right(a : elem, b : elem, c2 : sublist, u1 : unit2, u2 : unit2) : div sublist + SCons(b, cs2) -> + if a <= b then SCons(a, merge(cs1, SCons(b, cs2), u)) + else SCons(b, merge(SCons(a, cs1), cs2, u)) + STuple(b, c) -> + if a <= b then SCons(a, merge(cs1, STuple(b, c), u)) + else SCons(b, merge-last-left(SCons(a, cs1), c, u)) + STuple(a, b) -> match c2 + SCons(c, cs2) -> + if a <= c then SCons(a, merge-last-right(b, SCons(c, cs2), u)) + else SCons(c, merge(STuple(a, b), cs2, u)) + STuple(c, d) -> + if a <= c then SCons(a, merge-right(b, Pair(c, d), u)) + else SCons(c, merge-left(Pair(a, b), d, u)) + +fip fun merge-last-right(a : elem, c2 : sublist, u : unit2) : sublist match c2 - SCons(c, cs2) -> - if a > c then SCons(c, merge-last2-right(a, b, cs2, u1, u2)) - else SCons(a, merge-last-right(b, SCons(c, cs2), u1)) - STuple(c, d) -> - if a > c then - if a > d then SCons(c, SCons(d, STuple(a, b))) - elif b > d then SCons(c, SCons(a, STuple(d, b))) - else SCons(c, SCons(a, STuple(b, d))) - elif b > c then - if b > d then SCons(a, SCons(c, STuple(d, b))) - else SCons(a, SCons(c, STuple(b, d))) - else SCons(a, SCons(b, STuple(c, d))) - -fip fun merge-last-right(a : elem, c2 : sublist, u1 : unit2) : div sublist - match c2 - SCons(c, cs2) -> - if a > c then SCons(c, merge-last-right(a, cs2, u1)) - else SCons(a, SCons(c, cs2)) - STuple(b, c) -> - if a > b then - if a > c then SCons(b, STuple(c, a)) - else SCons(b, STuple(a, c)) - else SCons(a, STuple(b, c)) - -fip fun merge-last2-left(c2 : sublist, a : elem, b : elem, u1 : unit2, u2 : unit2) : div sublist - match c2 - SCons(c, cs2) -> - if a >= c then SCons(c, merge-last2-left(cs2, a, b, u1, u2)) - else SCons(a, merge-last-left(SCons(c, cs2), b, u1)) - STuple(c, d) -> - if a >= c then - if a >= d then SCons(c, SCons(d, STuple(a, b))) - elif b >= d then SCons(c, SCons(a, STuple(d, b))) - else SCons(c, SCons(a, STuple(b, d))) - elif b >= c then - if b >= d then SCons(a, SCons(c, STuple(d, b))) - else SCons(a, SCons(c, STuple(b, d))) - else SCons(a, SCons(b, STuple(c, d))) - -fip fun merge-last-left(c2 : sublist, a : elem, u1 : unit2) : div sublist + SCons(b, cs2) | a <= b -> SCons(a, SCons(b, cs2)) + | _ -> SCons(b, merge-last-right(a, cs2, u)) + STuple(b, c) -> merge-right(a, Pair(b, c), u) + +fip fun merge-last-left(c2 : sublist, d : elem, u : unit2) : sublist match c2 - SCons(c, cs2) -> - if a >= c then SCons(c, merge-last-left(cs2, a, u1)) - else SCons(a, SCons(c, cs2)) - STuple(b, c) -> - if a >= b then - if a >= c then SCons(b, STuple(c, a)) - else SCons(b, STuple(a, c)) - else SCons(a, STuple(b, c)) + SCons(a, cs2) | a <= d -> SCons(a, merge-last-left(cs2, d, u)) + | _ -> SCons(d, SCons(a, cs2)) + STuple(a, b) -> merge-left(Pair(a, b), d, u) + +fip fun merge-right(a : elem, p : pair, u : unit2) : sublist + match p + Pair(b, c) | a <= b -> SCons(a, STuple(b, c)) + | _ -> SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) + +fip fun merge-left(p : pair, d : elem, u : unit2) : sublist + match p + Pair(a, b) | a <= d -> SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) + | _ -> SCons(d, STuple(a, b)) fun rand-list(n : int32, seed : int32) :
list val a = 22695477.int32 diff --git a/test/fip/src/sort/sort_quick_fip.kk b/test/fip/src/sort/sort_quick_fip.kk index ee117ba0d..d7f94c3c3 100644 --- a/test/fip/src/sort/sort_quick_fip.kk +++ b/test/fip/src/sort/sort_quick_fip.kk @@ -18,8 +18,8 @@ type sublist STuple(a : a, b : a) type partition - Singleton(c : sublist, bdl : partition) - Sublist(c : a, bdl : partition) + Sublist(c : sublist, bdl : partition) + Singleton(c : a, bdl : partition) End fip fun quicksort(xs : list) : div list @@ -27,26 +27,21 @@ fip fun quicksort(xs : list) : div list fip fun quicksort-go(xs : list, b : partition) : div list match xs - Nil -> quicksort-app(b) Cons(p, xx) -> val (lo, hi) = split-list(p, xx, Done, b, Unit2(Pad,Pad)) quicksort-go(lo, hi) - -fip fun quicksort-sublist(xs : sublist, bdl : partition, u : unit2) : div list - match xs - SCons(p, xx) -> - val (lo, hi) = split-sublist(p, xx, Done, bdl, u, Unit2(Pad,Pad)) - quicksort-go(lo, hi) - STuple(a, b) -> - if a <= b - then Cons(a, Cons(b, quicksort-app(bdl))) - else Cons(b, Cons(a, quicksort-app(bdl))) + Nil -> quicksort-app(b) fip fun quicksort-app(bdl : partition) : div list match bdl + Singleton(p, b) -> Cons(p,quicksort-app(b)) + Sublist(xs, bdl') -> match xs + SCons(p, xx) -> + val (lo, hi) = split-sublist(p, xx, Done, bdl', Unit2(Pad,Pad), Unit2(Pad,Pad)) + quicksort-go(lo, hi) + STuple(a, b) | a <= b -> Cons(a, Cons(b, quicksort-app(bdl'))) + | _ -> Cons(b, Cons(a, quicksort-app(bdl'))) End -> Nil - Sublist(p, b) -> Cons(p,quicksort-app(b)) - Singleton(c, b) -> quicksort-sublist(c, b, Unit2(Pad,Pad)) type accum MkLo(x : a, k : accum) @@ -55,35 +50,33 @@ type accum fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) match xs - Nil -> split-app1(k, p, Nil, Nothing2, b, u) - Cons(x, xx) -> - if x < p - then split-list(p, xx, MkLo(x, k), b, u) - else split-list(p, xx, MkHi(x, k), b, u) + Cons(x, xx) | x < p -> split-list(p, xx, MkLo(x, k), b, u) + | _ -> split-list(p, xx, MkHi(x, k), b, u) + Nil -> + val (lo, hi) = split-app1(k, Nil, Nothing2, b) + (lo, Singleton(p, hi)) fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) match xs + SCons(x, xx) | x < p -> split-sublist(p, xx, MkLo(x, k), b, u, u1) + | _ -> split-sublist(p, xx, MkHi(x, k), b, u, u1) STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) - SCons(x, xx) -> - if x < p - then split-sublist(p, xx, MkLo(x, k), b, u, u1) - else split-sublist(p, xx, MkHi(x, k), b, u, u1) -fip fun split-app1(k : accum, p : elem, lo : list, hi : maybe2, b : partition, u : unit2) :
(list, partition) +fip fun split-app1(k : accum, lo : list, hi : maybe2, b : partition) :
(list, partition) match k - MkLo(x, k) -> split-app1(k, p, Cons(x, lo), hi, b, u) + MkLo(x, k) -> split-app1(k, Cons(x, lo), hi, b) MkHi(x, k) -> match hi - Nothing2 -> split-app1(k, p, lo, Just2(x, Pad), b, u) - Just2(y, _) -> split-app2(k, p, lo, STuple(x,y), b, u, Unit2(Pad,Pad)) + Nothing2 -> split-app1(k, lo, Just2(x, Pad), b) + Just2(y, _) -> split-app2(k, lo, STuple(y,x), b, Unit2(Pad,Pad)) Done -> match hi - Just2(x, _) -> (lo, Sublist(p, Sublist(x, b))) - Nothing2 -> (lo, Sublist(p, b)) + Just2(x, _) -> (lo, Singleton(x, b)) + Nothing2 -> (lo, b) -fip fun split-app2(k : accum, p : elem, lo : list, hi : sublist, b : partition, u : unit2, u1 : unit2) : (list, partition) +fip fun split-app2(k : accum, lo : list, hi : sublist, b : partition, u : unit2) : (list, partition) match k - MkLo(x, k) -> split-app2(k, p, Cons(x,lo), hi, b, u, u1) - MkHi(x, k) -> split-app2(k, p, lo, SCons(x,hi), b, u, u1) - Done -> (lo, Sublist(p, Singleton(hi, b))) + MkLo(x, k) -> split-app2(k, Cons(x,lo), hi, b, u) + MkHi(x, k) -> split-app2(k, lo, SCons(x,hi), b, u) + Done -> (lo, Sublist(hi, b)) fun rand-list(n : int32, seed : int32) :
list val a = 22695477.int32 From 480413231bfbde754542d56174de5a5cc2acb0a4 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 5 May 2023 18:35:07 -0700 Subject: [PATCH 167/233] Rename rbtree fip benchmarks --- test/fip/bench.sh | 2 +- test/fip/src/rbtree/rbtree_fip.kk | 94 ------------------- ...tree_fip_noreuse.kk => rbtree_fip_clrs.kk} | 2 +- test/fip/src/rbtree/rbtree_fip_icfp.kk | 39 ++++---- test/fip/src/rbtree/rbtree_icfp.kk | 77 --------------- 5 files changed, 19 insertions(+), 195 deletions(-) rename test/fip/src/rbtree/{rbtree_fip_noreuse.kk => rbtree_fip_clrs.kk} (99%) delete mode 100644 test/fip/src/rbtree/rbtree_icfp.kk diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 293a13ee9..2001fb5c5 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -6,7 +6,7 @@ dirs="tmap rbtree finger sort" benches_tmapkk="tmap/tmap_std.kk tmap/tmap_fip.kk tmap/tmap_std_noreuse.kk tmap/tmap_fip_noreuse.kk" benches_tmapc="tmap/tmap_std_mimalloc.c tmap/tmap_fip_mimalloc.c tmap/tmap_std.c tmap/tmap_fip.c" -benches_rbtreekk="rbtree/rbtree_icfp.kk rbtree/rbtree_std.kk rbtree/rbtree_fip.kk rbtree/rbtree_std_noreuse.kk rbtree/rbtree_fip_noreuse.kk" +benches_rbtreekk="rbtree/rbtree_fip_icfp.kk rbtree/rbtree_std.kk rbtree/rbtree_fip.kk rbtree/rbtree_fip_clrs.kk rbtree/rbtree_std_noreuse.kk" benches_rbtreec="rbtree/rbtree_clrs_mimalloc.c rbtree/rbtree_clrs_full_mimalloc.c rbtree/rbtree_clrs.c rbtree/rbtree_clrs_full.c" benches_sortkk="sort/sort_merge_std.kk sort/sort_merge_fip.kk sort/sort_quick_std.kk sort/sort_quick_fip.kk sort/sort_merge_std_noreuse.kk sort/sort_quick_std_noreuse.kk " benches_fingerkk="finger/finger_std.kk finger/finger_fip.kk finger/finger_std_noreuse.kk" diff --git a/test/fip/src/rbtree/rbtree_fip.kk b/test/fip/src/rbtree/rbtree_fip.kk index e21d0913d..4a4f6644c 100644 --- a/test/fip/src/rbtree/rbtree_fip.kk +++ b/test/fip/src/rbtree/rbtree_fip.kk @@ -80,97 +80,3 @@ fun test(n : int32) fun main() val n = get-args().head("").parse-int.default(100).int32 test(n) - -/* -import std/num/int32 -import std/os/env - -type color - Red - Black - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf - -fip fun is-red(^t : tree) : bool - match t - Node(Red) -> True - _ -> False - -type accum - Done - NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) - NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) - -fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree - match t - Node(c, l, kx, vx, r) - -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) - elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) - else balance(z, Node(c, l, key, v, r)) - Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) - -fip fun set-black(t : tree) : tree - match t - Node(_, l, k, v, r) -> Node(Black, l, k, v, r) - t -> t - -fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating - match z - NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) - NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) - Done -> t - -fip fun balance( z : accum, t : tree ) : exn tree - match z - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> // black - if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) - else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) - NodeL(_,z2,k2,v2,r2) -> // black - if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) - else match t - Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) - Done -> Node(Black, l1, k1, v1, t) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeL(_,z2,k2,v2,r2) -> // black - if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) - else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) - NodeR(_,l2,k2,v2,z2) -> // black - if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) - else match t - Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) - Done -> Node(Black, t, k1, v1, r1) - z -> rebuild(z, t) - - -fip(1) fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v, Done) - - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : pure tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : pure tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) -*/ \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip_noreuse.kk b/test/fip/src/rbtree/rbtree_fip_clrs.kk similarity index 99% rename from test/fip/src/rbtree/rbtree_fip_noreuse.kk rename to test/fip/src/rbtree/rbtree_fip_clrs.kk index 578fc521b..370801adc 100644 --- a/test/fip/src/rbtree/rbtree_fip_noreuse.kk +++ b/test/fip/src/rbtree/rbtree_fip_clrs.kk @@ -88,4 +88,4 @@ fun test(n : int32) fun main() val n = get-args().head("").parse-int.default(100).int32 - test(n) + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip_icfp.kk b/test/fip/src/rbtree/rbtree_fip_icfp.kk index 4a4f6644c..bec175dcc 100644 --- a/test/fip/src/rbtree/rbtree_fip_icfp.kk +++ b/test/fip/src/rbtree/rbtree_fip_icfp.kk @@ -1,8 +1,8 @@ import std/num/int32 import std/os/env -type any - Any +ref type pad + Pad type color Red @@ -12,11 +12,8 @@ type tree Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) Leaf() -type balance-node - Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - type reuse5 - Reuse5(a : color, b : any, c : any, d : bool, e : any) + Reuse5(a : color, b : pad, c : int32, d : bool, e : pad) type accum Done @@ -29,21 +26,19 @@ fip fun rebuild(z : accum, t : tree) : tree NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) Done -> t -fip fun balance( z : accum, t : balance-node ) : tree - match t - Balance(_,l,k,v,r) -> - match z - NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) - NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) - Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) - Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) - Done -> Node(Black,l,k,v,r) +fip fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : reuse5 ) : tree + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree match t @@ -51,7 +46,7 @@ fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) else rebuild(z, Node(c, l, kx, vx, r)) - Leaf -> balance(z, Balance(Black,Leaf, k, v, Leaf)) + Leaf -> balance(z, Leaf, k, v, Leaf, Reuse5(Red,Pad,0.int32,True,Pad)) fip(1) fun insert(t : tree, k : int32, v : bool) : tree ins(t, k, v, Done) diff --git a/test/fip/src/rbtree/rbtree_icfp.kk b/test/fip/src/rbtree/rbtree_icfp.kk deleted file mode 100644 index c0db85f64..000000000 --- a/test/fip/src/rbtree/rbtree_icfp.kk +++ /dev/null @@ -1,77 +0,0 @@ -import std/num/int32 -import std/os/env - -type any - Any - -type color - Red - Black - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf() - -type reuse5 - Reuse5(a : color, b : any, c : any, d : bool, e : any) - -type accum - Done - NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) - NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) - -fun rebuild(z : accum, t : tree) : tree - match z - NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) - NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) - Done -> t - -fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : reuse5 ) : tree - match z - NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) - NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) - Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) - Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) - Done -> Node(Black,l,k,v,r) - -fun ins(t : tree, k : int32, v : bool, z : accum) : tree - match t - Node(c, l, kx, vx, r) - -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) - elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) - else rebuild(z, Node(c, l, kx, vx, r)) - Leaf -> balance(z, Leaf, k, v, Leaf, Reuse5(Red,Any,Any,True,Any)) - -fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v, Done) - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : pure tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : pure tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) From 0f8d2801626fc685d25e3bbbc30829f29d7589f9 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 08:04:15 -0700 Subject: [PATCH 168/233] remove reuse5 --- test/fip/src/rbtree/rbtree_fip.kk | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/test/fip/src/rbtree/rbtree_fip.kk b/test/fip/src/rbtree/rbtree_fip.kk index e21d0913d..e0b7c2c61 100644 --- a/test/fip/src/rbtree/rbtree_fip.kk +++ b/test/fip/src/rbtree/rbtree_fip.kk @@ -15,9 +15,6 @@ type tree type balance-node Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) -type reuse5 - Reuse5(a : color, b : any, c : any, d : bool, e : any) - type accum Done NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) @@ -51,7 +48,7 @@ fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) else rebuild(z, Node(c, l, kx, vx, r)) - Leaf -> balance(z, Balance(Black,Leaf, k, v, Leaf)) + Leaf -> balance(z, Balance(Black, Leaf, k, v, Leaf)) fip(1) fun insert(t : tree, k : int32, v : bool) : tree ins(t, k, v, Done) From 6f06a7ed3e34f6bf53d278b9620a6cf2902be9d1 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 08:09:29 -0700 Subject: [PATCH 169/233] update mimalloc to v2.1.2 --- kklib/mimalloc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index a582d760e..5e09f1b05 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit a582d760ed8266af9fab445bf3e06e65d073a6f3 +Subproject commit 5e09f1b051738bd3823e7617cf4cbc6cbb9e762c From 062f5cfc6609d676728b34c18226ab35aefb1a79 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 09:51:39 -0700 Subject: [PATCH 170/233] reorg fip benchmarks and script --- test/fip/bench.sh | 245 ++++++++++++--- test/fip/src/finger/finger_fip.kk | 283 ------------------ test/fip/src/finger/finger_std.kk | 112 ------- test/fip/src/finger/finger_std_noreuse.kk | 112 ------- test/fip/src/rbtree/rbtree_clrs.c | 183 ----------- test/fip/src/rbtree/rbtree_clrs_full.c | 187 ------------ .../src/rbtree/rbtree_clrs_full_mimalloc.c | 188 ------------ test/fip/src/rbtree/rbtree_clrs_mimalloc.c | 184 ------------ test/fip/src/rbtree/rbtree_cpp.cpp | 64 ---- test/fip/src/rbtree/rbtree_fip.kk | 79 ----- test/fip/src/rbtree/rbtree_fip_clrs.kk | 91 ------ test/fip/src/rbtree/rbtree_fip_icfp.kk | 77 ----- test/fip/src/rbtree/rbtree_std.kk | 91 ------ test/fip/src/rbtree/rbtree_std_noreuse.kk | 91 ------ test/fip/src/sort/sort_merge_fip.kk | 133 -------- test/fip/src/sort/sort_merge_std.kk | 58 ---- test/fip/src/sort/sort_merge_std_noreuse.kk | 58 ---- test/fip/src/sort/sort_quick_fip.kk | 97 ------ test/fip/src/sort/sort_quick_std.kk | 40 --- test/fip/src/sort/sort_quick_std_noreuse.kk | 40 --- test/fip/src/tmap/tmap_fip.c | 101 ------- test/fip/src/tmap/tmap_fip.kk | 47 --- test/fip/src/tmap/tmap_fip_mimalloc.c | 102 ------- test/fip/src/tmap/tmap_fip_noreuse.kk | 47 --- test/fip/src/tmap/tmap_std.c | 82 ----- test/fip/src/tmap/tmap_std.kk | 34 --- test/fip/src/tmap/tmap_std_mimalloc.c | 83 ----- test/fip/src/tmap/tmap_std_noreuse.kk | 34 --- 28 files changed, 200 insertions(+), 2743 deletions(-) delete mode 100644 test/fip/src/finger/finger_fip.kk delete mode 100644 test/fip/src/finger/finger_std.kk delete mode 100644 test/fip/src/finger/finger_std_noreuse.kk delete mode 100644 test/fip/src/rbtree/rbtree_clrs.c delete mode 100644 test/fip/src/rbtree/rbtree_clrs_full.c delete mode 100644 test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c delete mode 100644 test/fip/src/rbtree/rbtree_clrs_mimalloc.c delete mode 100644 test/fip/src/rbtree/rbtree_cpp.cpp delete mode 100644 test/fip/src/rbtree/rbtree_fip.kk delete mode 100644 test/fip/src/rbtree/rbtree_fip_clrs.kk delete mode 100644 test/fip/src/rbtree/rbtree_fip_icfp.kk delete mode 100644 test/fip/src/rbtree/rbtree_std.kk delete mode 100644 test/fip/src/rbtree/rbtree_std_noreuse.kk delete mode 100644 test/fip/src/sort/sort_merge_fip.kk delete mode 100644 test/fip/src/sort/sort_merge_std.kk delete mode 100644 test/fip/src/sort/sort_merge_std_noreuse.kk delete mode 100644 test/fip/src/sort/sort_quick_fip.kk delete mode 100644 test/fip/src/sort/sort_quick_std.kk delete mode 100644 test/fip/src/sort/sort_quick_std_noreuse.kk delete mode 100644 test/fip/src/tmap/tmap_fip.c delete mode 100644 test/fip/src/tmap/tmap_fip.kk delete mode 100644 test/fip/src/tmap/tmap_fip_mimalloc.c delete mode 100644 test/fip/src/tmap/tmap_fip_noreuse.kk delete mode 100644 test/fip/src/tmap/tmap_std.c delete mode 100644 test/fip/src/tmap/tmap_std.kk delete mode 100644 test/fip/src/tmap/tmap_std_mimalloc.c delete mode 100644 test/fip/src/tmap/tmap_std_noreuse.kk diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 2001fb5c5..b53e44e42 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -1,15 +1,15 @@ -# list sizes -runparams="1 10 100 1000 10000 100000 1000000" +# +runparams="10000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" dirs="tmap rbtree finger sort" -benches_tmapkk="tmap/tmap_std.kk tmap/tmap_fip.kk tmap/tmap_std_noreuse.kk tmap/tmap_fip_noreuse.kk" -benches_tmapc="tmap/tmap_std_mimalloc.c tmap/tmap_fip_mimalloc.c tmap/tmap_std.c tmap/tmap_fip.c" -benches_rbtreekk="rbtree/rbtree_fip_icfp.kk rbtree/rbtree_std.kk rbtree/rbtree_fip.kk rbtree/rbtree_fip_clrs.kk rbtree/rbtree_std_noreuse.kk" -benches_rbtreec="rbtree/rbtree_clrs_mimalloc.c rbtree/rbtree_clrs_full_mimalloc.c rbtree/rbtree_clrs.c rbtree/rbtree_clrs_full.c" -benches_sortkk="sort/sort_merge_std.kk sort/sort_merge_fip.kk sort/sort_quick_std.kk sort/sort_quick_fip.kk sort/sort_merge_std_noreuse.kk sort/sort_quick_std_noreuse.kk " -benches_fingerkk="finger/finger_std.kk finger/finger_fip.kk finger/finger_std_noreuse.kk" +benches_tmapkk="tmap/tmap-std.kk tmap/tmap-fip.kk" +benches_tmapc="tmap/tmap-std.c tmap/tmap-fip.c" +benches_rbtreekk="rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std.kk rbtree/rbtree-fip.kk rbtree/rbtree-fip-clrs.kk" +benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" +benches_sortkk="sort/msort-std.kk sort/msort-fip.kk sort/qsort-std.kk sort/qsort-fip.kk" +benches_fingerkk="finger/ftree-std.kk finger/ftree-fip.kk" benches_all="$benches_tmapkk $benches_tmapc $benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk" # get this by running `stack path | grep local-install-root`` in the koka development directory @@ -37,11 +37,18 @@ echo "using koka: $koka" coutdir=".koka/ccomp" copts="" +cppoutdir=".koka/cppcomp" +cppopts="" + +mimalloc="mimalloc-2.1" +mimalloc_usr_local="/usr/local/" + gtime="/usr/bin/time" if command -v "gtime"; then gtime=`which gtime` fi +cppcomp="clang++" ccomp="clang" benches="" @@ -79,6 +86,7 @@ function warning { ensure_dir "log" ensure_dir ".koka/ccomp" +ensure_dir ".koka/cppcomp" while : ; do # set flag and flag_arg @@ -110,8 +118,11 @@ while : ; do rbtreec) benches="$benches $benches_rbtreec";; ccomp) ccomp="$flag_arg";; - gcc) ccomp="gcc";; - clang) ccomp="clang";; + cppcomp) cppcomp="$flag_arg";; + gcc) ccomp="gcc" + cppcomp="g++";; + clang) ccomp="clang" + cppcomp="clang++";; build) do_build="yes";; run) do_run="yes" @@ -140,54 +151,119 @@ while : ; do echo " -h, --help show this help" echo " -v, --verbose be verbose (=$verbose)" echo "" + echo "see 'bench.sh' for all available options" + echo "" exit 0;; *) warning "unknown option \"$1\"." 1>&2 esac shift done -function build_kk { # - local options="-O2 --no-debug --cc=$ccomp --buildtag=bench $kkopts" - if [[ "$1" == *"noreuse.kk"* ]]; then +# add -noreuse to std, and -mi to c/cpp +function expand_benches { + local newb="" + for bench in $benches; do + local base=${bench%.*} + if [[ $bench == *-std\.kk ]]; then + newb="$newb $bench $base-noreuse.kk" + elif [[ $bench == *\.c ]]; then + newb="$newb $bench $base-mi.c" + elif [[ $bench == *\.cpp ]]; then + newb="$newb $bench $base-mi.cpp" + else + newb="$newb $bench" + fi + done + benches=$newb + echo "expanded benches: $benches" +} + +expand_benches + +function build_kk { # + + local srcname="$1" + local base=${1%.*} # no ext + local stem=${base##*/} # dashed dir + local options="-O2 --no-debug --cc=$ccomp --buildtag=bench --buildname=$stem $kkopts" + if [[ $1 == *-noreuse\.kk ]]; then options="$options --fno-reuse" + srcname="${1%-noreuse.kk}.kk" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$koka $options -i$benchdir $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd + # "$koka" $options -i$benchdir $benchdir/$srcname fi - info "" - info "build: $1, ($options)" - "$koka" $options -i$benchdir $benchdir/$1 } function build_c { # + local srcname="$1" local base=${1%.*} - local dbase=${base//\//_} - local options="-O3 -o $coutdir/$dbase $copts" + local stem=${base##*/} + local options="-O3 -o $coutdir/$stem $copts" if [[ $(uname -m) == 'arm64' ]]; then options="$options -mcpu=apple-m1" else options="$options -march=native" fi - if [[ "$1" == *"mimalloc.c"* ]]; then - options="$options -L /usr/local/lib/mimalloc-2.0 -I /usr/local/include/mimalloc-2.0 -lmimalloc" + if [[ "$1" == *"-mi"* ]]; then + options="$options -L ${mimalloc_usr_local}lib/$mimalloc -I ${mimalloc_usr_local}include/$mimalloc -lmimalloc" + srcname="${1%-mi.c}.c" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$ccomp $options $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd + fi +} + +function build_cpp { # + local srcname="$1" + local base=${1%.*} + local stem=${base##*/} + local options="-O3 -o $cppoutdir/$stem $cppopts" + if [[ $(uname -m) == 'arm64' ]]; then + options="$options -mcpu=apple-m1" + else + options="$options -march=native" + fi + if [[ "$1" == *"-mi"* ]]; then + options="$options -L ${mimalloc_usr_local}lib/$mimalloc -I ${mimalloc_usr_local}include/$mimalloc -lmimalloc" + srcname="${1%-mi.cpp}.cpp" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$cppcomp $options $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd fi - info "" - info "build: $1, ($options)" - "$ccomp" $options $benchdir/$1 } function build_all { for bench in $benches; do - if ! [ -f "$benchdir/$bench" ]; then - info "skip $bench -- not found" - elif [[ $bench == *\.kk ]]; then + if [[ $bench == *\.kk ]]; then build_kk $bench $ccomp elif [[ $bench == *\.c ]]; then build_c $bench + elif [[ $bench == *\.cpp ]]; then + build_cpp $bench else warning "define build compiler for $bench" fi done } -function run { #bname cmd runidx log runparam +function run { #label cmd runidx log runparam info "" info "run $1, iter $3, cmd: $2" local logrun="./log/run.txt" @@ -207,22 +283,24 @@ function run_all { local exe="" local prefix=${bench#*\.} local base=${bench%\.*} # no extension - local dbase=${base//\//_} + local stem=${base##*/} # no directory if [[ $bench == *\.kk ]]; then - exe=".koka/${koka_ver}-bench/$ccomp-release/$dbase" + exe=".koka/${koka_ver}-bench/$ccomp-release/$stem" elif [[ $bench == *\.c ]]; then - exe=".koka/ccomp/$dbase" + exe=".koka/ccomp/$stem" + elif [[ $bench == *\.cpp ]]; then + exe=".koka/cppcomp/$stem" fi local cmd="$exe" if ! [ -f $exe ]; then - info "bench $base: NA (exe not found: $exe)" + info "bench $stem: NA (exe not found: $exe)" elif [ -z $cmd ]; then - info "bench $base: NA (no command)" # define for ML + info "bench $rtem: NA (no command)" # define for ML else for runparam in $runparams; do - local bname="${prefix}_${dbase}_$runparam" + local bname="${prefix}__${stem}__$runparam" local log="./log/$bname.txt" rm -f $log 2> /dev/null for ((runs=1; runs<=$max_runs; runs++)); do @@ -265,16 +343,17 @@ function avg { #bname log logbench $4= map function avg_all { local logbench="./log/avg.txt" rm -f $logbench 2> /dev/null + echo "# benchmark variant param elapsed relative stddev rss" >> $logbench for dir in $dirs; do for runparam in $runparams; do basetime="" for bench in $benches; do local prefix=${bench#*\.} local base=${bench%\.*} # no extension - local dbase=${base//\//_} + local stem=${base##*/} local bdir=$(echo $base | cut -d'/' -f 1) - local variant=${base#*\_} - local bname="${prefix}_${dbase}_${runparam}" + local variant=${stem#*-} + local bname="${prefix}__${stem}__${runparam}" local log="./log/$bname.txt" if [ "$dir" = "$bdir" ]; then avg $bname $log $logbench $prefix $dir $variant $runparam @@ -285,11 +364,14 @@ function avg_all { echo "" >> $logbench done echo "" - echo "# benchmark elapsed relat. stddev rss" column -t $logbench } -function graph_variant { # map + +#-------------------------------------- +# graph with xtick each benchmark + +function xgraph_variant { # map # $1 $2 $3 $4 $5 $6 $7 $8 $9 # log entry: kk map trmc 1000 awk ' @@ -297,6 +379,7 @@ function graph_variant { # map prefix="'"$1"'" bench="'"$2"'" variant="'"$3"'" + varianttexname="'"$4"'" print "\\pgfplotstableread{" print "x y y-error meta" } @@ -312,10 +395,10 @@ function graph_variant { # map } } END { - print "}\\datatime" prefix bench variant + print "}\\datatime" prefix bench varianttexname print " " } - ' $4 >> $5 + ' $5 >> $6 } function graph_all { @@ -345,11 +428,83 @@ function graph_all { for bench in $benches; do local prefix=${bench#*\.} local base=${bench%\.*} # no extension - local bbench=${base#*\/} # no directory - local variant=${bbench#*\_} - local benchname=${bbench%\_*} - # echo "$benchname, $variant" - graph_variant $prefix $benchname $variant $logbench $texdata + local stem=${base##*\/} # no directory + local variant=${stem#*-} + local varianttexname="${variant//-/x/}" + local benchname=${stem%%-*} + echo "GRAPH $benchname, $variant" + xgraph_variant $prefix $benchname $variant $varianttexname $logbench $texdata + done + cat $texdata +} + + +#------------------------------------- +# graph with the x ticks for each runparam + +function xgraph_variant { # map + # $1 $2 $3 $4 $5 $6 $7 $8 $9 + # log entry: kk map trmc 1000 + awk ' + BEGIN { + prefix="'"$1"'" + bench="'"$2"'" + variant="'"$3"'" + varianttexname="'"$4"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $1==prefix && $2==bench && $3==variant { + if ($1 == "kk" && $3 == "trmc") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.2f}}\n", i++, $6, $7, $5 ); + } + else if ($6 == 0.1) { + printf( "%i 0.100 0.000 {\\!\\!out of stack}\n", i++); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($6>3 ? 3 : $6), $7, $6); + } + } + END { + print "}\\datatime" prefix bench varianttexname + print " " + } + ' $5 >> $6 +} + +function xgraph_all { + local logbench="./log/avg.txt" + local texdata="./log/graph.tex" + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + #local benchname="" + #for bench in $benches; do + # local bbench=${bench#*\/} # no directory + # benchname=${bbench%\_*} + # break + #done + for runparam in $runparams; do + local lab="$runparam" + if [ "$lab" = "10000" ]; then + lab="10\\nsep 000" + elif [ "$lab" = "100000" ]; then + lab="100\\nsep 000" + elif [ "$lab" = "1000000" ]; then + lab="1\\nsep 000\\nsep 000" + fi + echo " \\strut $lab," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + for bench in $benches; do + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local stem=${base##*\/} # no directory + local variant=${stem#*-} + local varianttexname="${variant//-/}" + local benchname=${stem%%-*} + echo "GRAPH $benchname, $variant" + xgraph_variant $prefix $benchname $variant $varianttexname $logbench $texdata done cat $texdata } diff --git a/test/fip/src/finger/finger_fip.kk b/test/fip/src/finger/finger_fip.kk deleted file mode 100644 index be025f0a0..000000000 --- a/test/fip/src/finger/finger_fip.kk +++ /dev/null @@ -1,283 +0,0 @@ -// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen -import std/num/int32 -import std/os/env - -ref type pad - Pad - -type reuse3 - Reuse3(a : pad, b : pad, c : pad) - -type afew - One(a : a, b : pad, c : pad) - Two(a : a, b : a, c : pad) - Three(a : a, b : a, c : a) - -type tuple - Pair(a : a, b : a, c : pad) - Triple(a : a, b : a, c : a) - -type seq - Empty - Unit(a : a, b : pad, c : pad) - More0(l : a, s : seq>, r : afew) - More(l : tuple, s : seq>, r : afew) - -type buffer - BNil - BCons(next : buffer, b : pad, c : pad) - -value type bseq - BSeq(s : seq, q : buffer) - -// Isomorphic to (,,,) but unboxed -value type tuple4 - Tuple4(fst:a,snd:b,thd:c,field4:d) - -fun bhead(^bs : bseq) : exn a - match bs - BSeq(s, _) -> head(s) - -fun head(^s : seq) : exn a - match s - Unit(x) -> x - More0(x, _, _) -> x - More(Pair(x, _, _), _, _) -> x - More(Triple(x, _, _), _, _) -> x - -fip fun bcons(x : a, u3 : reuse3, bs : bseq) : exn bseq - val BSeq(s, b) = bs - val (s', b') = cons(x, u3, s, b) - BSeq(s', b') - -fip fun cons(x : a, u3 : reuse3, s : seq, b : buffer) : exn (seq, buffer) - match s - Empty -> (Unit(x, Pad, Pad), b) - Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) - More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) - More(Pair(y, z, _), q, u) -> - (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) - More(Triple(y, z, w), q, u) -> - val BCons(b', _, _) = b - val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') - (More(Pair(x, y, Pad), q', u), b'') - -fip fun buncons(bs : bseq) : exn (a, reuse3, bseq) - val BSeq(s, b) = bs - val Tuple4(x, u3, s', b') = uncons(s, b) - (x, u3, BSeq(s', b')) - -fip fun uncons(s : seq, b : buffer) : exn tuple4, buffer> - match s - Unit(x, _, _) -> - Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) - More(Triple(x, y, z), q, u) -> - val BCons(b', _, _) = b - Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') - More(Pair(x, y, _), q, u) -> - Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) - More0(x, q, u) -> - val (q', b') = more0(q, u, b) - Tuple4(x, Reuse3(Pad,Pad,Pad), q', b') - -fip fun more0(q : seq>, u : afew, b : buffer) : exn (seq, buffer) - match q - Empty -> - match u - One(x, y, z) -> (Unit(x, y, z), b) - Two(y, z, _) -> - val BCons(b', _, _) = b - (More0(y, Empty, One(z, Pad, Pad)), b') - Three(y, z, w) -> - val BCons(b', _, _) = b - (More0(y, Empty, Two(z, w, Pad)), b') - Unit(p, _, _) -> - match p - Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) - Triple(x, y, z) -> - val BCons(b', _, _) = b - (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') - More0(p, q1, u1) -> - match p - Pair(x, y) -> - val (q1', b') = more0(q1, u1, b) - (More(Pair(x, y, Pad), q1', u), b') - Triple(x, y, z) -> - val BCons(b', _, _) = b - (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') - More(Pair(p, y1), q1, u1) -> - match p - Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) - Triple(x, y, z) -> - val BCons(b', _, _) = b - (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') - More(Triple(p, y1, z1), q1, u1) -> - val BCons(b', _, _) = b - match p - Pair(x, y) -> - (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') - Triple(x, y, z) -> - (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') - -fip fun bsnoc(bs : bseq, u3 : reuse3, x : a) : exn bseq - val BSeq(s, b) = bs - val (s', b') = snoc(s, b, u3, x) - BSeq(s', b') - -fip fun snoc(s : seq, b : buffer, u3 : reuse3, x : a) : exn (seq, buffer) - match s - Empty -> (Unit(x, Pad, Pad), b) - Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) - More0(u, q, One(y, _, _)) -> (More0(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) - More (u, q, One(y, _, _)) -> (More (u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) - More0(u, q, Two(y, z, _)) -> (More0(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) - More (u, q, Two(y, z, _)) -> (More (u, q, Three(y, z, x)), BCons(b, Pad, Pad)) - More0(u, q, Three(y, z, w)) -> - val BCons(b', _, _) = b - val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) - (More0(u, q', Two(w, x, Pad)), b'') - More(u, q, Three(y, z, w)) -> - val BCons(b', _, _) = b - val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) - (More(u, q', Two(w, x, Pad)), b'') - -// append - -type list3 - Cons3(x : a, xx : list3, c : pad) - Nil3 - -fip fun reverse3(xs : list3) : list3 - reverse-append3( xs, Nil3 ) - -fip fun reverse-acc(acc : list3, ys : list3 ) : list3 - match ys - Cons3(x,xx,pad) -> reverse-acc(Cons3(x,acc,pad),xx) - _ -> acc - -fip fun reverse-append3( xs : list3, tl : list3 ) : list3 - reverse-acc(tl,xs) - -fip fun (++)(xs : list3, ys : list3 ) : list3 - append3(xs, ys) - -fip fun append3(xs : list3, ys : list3 ) : list3 - match xs - Cons3(x,xx,pad) -> Cons3(x,append3(xx,ys),pad) - Nil3 -> ys - -fip fun foldl3(xs,z1,z2,^f) - match xs - Cons3(x,xx) -> - val (z1', z2') = f(z1,z2,Reuse3(Pad,Pad,Pad),x) - foldl3(xx,z1',z2',f) - Nil3 -> (z1,z2) - -// foldl3 specialized to the `flip` function -fip fun foldl3_flipped(xs,z1,z2,^f) - match xs - Cons3(x,xx) -> - val (z1', z2') = f(x,Reuse3(Pad,Pad,Pad),z1,z2) - foldl3_flipped(xx,z1',z2',f) - Nil3 -> (z1,z2) - -fip fun foldr3(xs,z1,z2,^f) - xs.reverse3.foldl3_flipped(z1,z2,f) - -fip fun (++)( xs : buffer, ys : buffer ) : buffer - append-buffers(xs, ys) - -fip fun append-buffers(b1 : buffer, b2 : buffer) : buffer - match b1 - BNil -> b2 - BCons(b', _, _) -> BCons(append-buffers(b', b2), Pad, Pad) - -fip fun afew-to-list(u : afew, b : buffer) : exn (list3, buffer) - match u - One(x) -> (Cons3(x, Nil3, Pad), b) - Two(x,y) -> - match b - BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') - Three(x,y,z) -> - match b - BCons(BCons(b', _, _), _, _) -> - (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') - -fip fun tuple-to-list(u : tuple, b : buffer) : exn (list3, buffer) - match u - Pair(x,y) -> - match b - BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') - Triple(x,y,z) -> - match b - BCons(BCons(b', _, _), _, _) -> - (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') - -fip fun to-tuples(xs : list3, b : buffer) : (list3>, buffer) - match xs - Cons3(x, Cons3(y, Nil3)) -> - (Cons3(Pair(x,y,Pad), Nil3, Pad), b) - Cons3(x, Cons3(y, Cons3(z, Cons3(w, Nil3)))) -> - (Cons3(Pair(x,y,Pad), Cons3(Pair(z,w,Pad),Nil3,Pad), Pad), b) - Cons3(x, Cons3(y, Cons3(z, xs))) -> - val (xs', b') = to-tuples(xs, b) - (Cons3(Triple(x,y,z), xs', Pad), BCons(b', Pad, Pad)) - _ -> (Nil3, b) // only if xs == Nil3 - -fip fun append(q1 : bseq, q2 : bseq) : pure bseq - match (q1, q2) - (BSeq(q1, b1), BSeq(q2, b2)) -> - val (q, b) = glue(q1, b1, Nil3, BNil, q2, b2) - BSeq(q, b) - -fip fun glue(q1 : seq, b1 : buffer, xs : list3, bs0 : buffer, q2 : seq, b2 : buffer) : pure (seq, buffer) - match(q1, q2) - (Empty, q2) -> xs.foldr3(q2, (bs0 ++ b1 ++ b2), cons) - (q1, Empty) -> xs.foldl3(q1, (bs0 ++ b2 ++ b1), snoc) - (Unit(x,_,_), q2) -> (Cons3(x,xs,Pad)).foldr3(q2, (bs0 ++ b1 ++ b2), cons) - (q1, Unit(x,_,_)) -> append3(xs,Cons3(x,Nil3,Pad)).foldl3(q1, (bs0 ++ b2 ++ b1), snoc) - (More(u1, q1, v1), More(u2, q2, v2)) -> - val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) - val (u2', bs2) = tuple-to-list(u2, bs1) - val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) - val (q, b) = glue(q1, b1, ts, bs3, q2, b2) - (More(u1, q, v2), b) - (More0(u1, q1, v1), More(u2, q2, v2)) -> - val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) - val (u2', bs2) = tuple-to-list(u2, bs1) - val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) - val (q, b) = glue(q1, b1, ts, bs3, q2, b2) - (More0(u1, q, v2), b) - (More(u1, q1, v1), More0(u2, q2, v2)) -> - val (v1', bs1) = afew-to-list(v1, bs0) - val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) - val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) - val (q, b) = glue(q1, b1, ts, bs3, q2, b2) - (More(u1, q, v2), b) - (More0(u1, q1, v1), More0(u2, q2, v2)) -> - val (v1', bs1) = afew-to-list(v1, bs0) - val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) - val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) - val (q, b) = glue(q1, b1, ts, bs3, q2, b2) - (More0(u1, q, v2), b) - -// benchmark - -fun iterate(s : bseq, n : int32) : bseq - if n <= 0.int32 then s - else - val (x, u3, s') = buncons(s) - iterate(bsnoc(s', u3, x), n - 1.int32) - -fun build(n : int32, s : bseq) : bseq - if n <= 0.int32 then s else build(n - 1.int32, bsnoc(s, Reuse3(Pad,Pad,Pad), n)) - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val s = build(n, BSeq(Empty, BNil)) - acc + bhead(iterate(s, n * 3.int32)) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/finger/finger_std.kk b/test/fip/src/finger/finger_std.kk deleted file mode 100644 index bcfbfd7e8..000000000 --- a/test/fip/src/finger/finger_std.kk +++ /dev/null @@ -1,112 +0,0 @@ -// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen -import std/num/int32 -import std/os/env - -// Originally "some" which is a reserved keyword in Koka -type afew - One(a : a) - Two(a : a, b : a) - Three(a : a, b : a, c : a) - -type tuple - Pair(a : a, b : a) - Triple(a : a, b : a, c : a) - -type seq - Empty // Nil is used for the empty list in Koka - Unit(a : a) - More(l : afew, s : seq>, r : afew) - -fun head(s : seq) : a - match s - Unit(x) -> x - More(One(x), _, _) -> x - More(Two(x, _), _, _) -> x - More(Three(x, _, _), _, _) -> x - -fun cons(x : a, s : seq) : seq - match s - Empty -> Unit(x) - Unit(y) -> More(One(x), Empty, One(y)) - More(One(y), q, u) -> More(Two(x, y), q, u) - More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) - More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) - -fun uncons(s : seq) : (a, seq) - match s - Unit(x) -> (x, Empty) - More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) - More(Two(x, y), q, u) -> (x, More(One(y), q, u)) - More(One(x), q, u) -> (x, more0(q, u)) - -// we inline chop and map1 for better reuse behaviour -fun more0(q : seq>, u : afew) : seq - match q - Empty -> match u - One(y) -> Unit(y) - Two(y, z) -> More(One(y), Empty, One(z)) - Three(y, z, w) -> More(One(y), Empty, Two(z, w)) - Unit(p) -> match p - Pair(x, y) -> More(Two(x, y), Empty, u) - Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) - More(One(p), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) - Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) - More(Two(p, y1), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) - Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) - More(Three(p, y1, z1), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) - Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) - -fun snoc(s : seq, x : a) : seq - match s - Empty -> Unit(x) - Unit(y) -> More(One(y), Empty, One(x)) - More(u, q, One(y)) -> More(u, q, Two(y, x)) - More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) - More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) - -fun to-list(u : afew) : list - match u - One(x) -> [x] - Two(x,y) -> [x,y] - Three(x,y,z) -> [x,y,z] - -fun to-tuples(xs : list) : list> - match xs - Cons(x, Cons(y, Nil)) -> [Pair(x,y)] - Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] - Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) - _ -> [] // only if xs == Nil - -fun append(q1 : seq, q2 : seq) :
seq - glue(q1, Nil, q2) - -fun glue(q1 : seq, xs : list, q2 : seq) :
seq - match(q1, q2) - (Empty, _) -> xs.foldr(q2, cons) - (_, Empty) -> xs.foldl(q1, snoc) - (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) - (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) - (More(u1, q1, v1), More(u2, q2, v2)) -> - More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) - -fun iterate(s : seq, n : int32) : seq - if n <= 0.int32 then s - else - val (x, s') = uncons(s) - iterate(snoc(s', x), n - 1.int32) - -fun build(n : int32, s : seq) :
seq - if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val s = build(n, Empty) - acc + head(iterate(s, n * 3.int32)) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/finger/finger_std_noreuse.kk b/test/fip/src/finger/finger_std_noreuse.kk deleted file mode 100644 index bcfbfd7e8..000000000 --- a/test/fip/src/finger/finger_std_noreuse.kk +++ /dev/null @@ -1,112 +0,0 @@ -// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen -import std/num/int32 -import std/os/env - -// Originally "some" which is a reserved keyword in Koka -type afew - One(a : a) - Two(a : a, b : a) - Three(a : a, b : a, c : a) - -type tuple - Pair(a : a, b : a) - Triple(a : a, b : a, c : a) - -type seq - Empty // Nil is used for the empty list in Koka - Unit(a : a) - More(l : afew, s : seq>, r : afew) - -fun head(s : seq) : a - match s - Unit(x) -> x - More(One(x), _, _) -> x - More(Two(x, _), _, _) -> x - More(Three(x, _, _), _, _) -> x - -fun cons(x : a, s : seq) : seq - match s - Empty -> Unit(x) - Unit(y) -> More(One(x), Empty, One(y)) - More(One(y), q, u) -> More(Two(x, y), q, u) - More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) - More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) - -fun uncons(s : seq) : (a, seq) - match s - Unit(x) -> (x, Empty) - More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) - More(Two(x, y), q, u) -> (x, More(One(y), q, u)) - More(One(x), q, u) -> (x, more0(q, u)) - -// we inline chop and map1 for better reuse behaviour -fun more0(q : seq>, u : afew) : seq - match q - Empty -> match u - One(y) -> Unit(y) - Two(y, z) -> More(One(y), Empty, One(z)) - Three(y, z, w) -> More(One(y), Empty, Two(z, w)) - Unit(p) -> match p - Pair(x, y) -> More(Two(x, y), Empty, u) - Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) - More(One(p), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) - Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) - More(Two(p, y1), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) - Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) - More(Three(p, y1, z1), q1, u1) -> match p - Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) - Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) - -fun snoc(s : seq, x : a) : seq - match s - Empty -> Unit(x) - Unit(y) -> More(One(y), Empty, One(x)) - More(u, q, One(y)) -> More(u, q, Two(y, x)) - More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) - More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) - -fun to-list(u : afew) : list - match u - One(x) -> [x] - Two(x,y) -> [x,y] - Three(x,y,z) -> [x,y,z] - -fun to-tuples(xs : list) : list> - match xs - Cons(x, Cons(y, Nil)) -> [Pair(x,y)] - Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] - Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) - _ -> [] // only if xs == Nil - -fun append(q1 : seq, q2 : seq) :
seq - glue(q1, Nil, q2) - -fun glue(q1 : seq, xs : list, q2 : seq) :
seq - match(q1, q2) - (Empty, _) -> xs.foldr(q2, cons) - (_, Empty) -> xs.foldl(q1, snoc) - (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) - (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) - (More(u1, q1, v1), More(u2, q2, v2)) -> - More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) - -fun iterate(s : seq, n : int32) : seq - if n <= 0.int32 then s - else - val (x, s') = uncons(s) - iterate(snoc(s', x), n - 1.int32) - -fun build(n : int32, s : seq) :
seq - if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val s = build(n, Empty) - acc + head(iterate(s, n * 3.int32)) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs.c b/test/fip/src/rbtree/rbtree_clrs.c deleted file mode 100644 index 1a31ca7dc..000000000 --- a/test/fip/src/rbtree/rbtree_clrs.c +++ /dev/null @@ -1,183 +0,0 @@ -// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein - -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -enum Color { RED, BLACK }; -enum Bool { TRUE, FALSE }; - -typedef struct Node { - int32_t key; - enum Bool value; - enum Color color; - struct Node *left; - struct Node *right; - struct Node *parent; -} Node; - -typedef struct RedBlackTree { - Node *nil; - Node *root; -} RedBlackTree; - -void left_rotate(RedBlackTree *T, Node *x) { - Node *y = x->right; - x->right = y->left; - if (y->left != T->nil) { - y->left->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->left) { - x->parent->left = y; - } else { - x->parent->right = y; - } - y->left = x; - x->parent = y; -} - -void right_rotate(RedBlackTree *T, Node *x) { - Node *y = x->left; - x->left = y->right; - if (y->right != T->nil) { - y->right->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->right) { - x->parent->right = y; - } else { - x->parent->left = y; - } - y->right = x; - x->parent = y; -} - -void insert_fixup(RedBlackTree *T, Node *z) { - while (z->parent->color == RED) { - if (z->parent == z->parent->parent->left) { - Node *y = z->parent->parent->right; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->right) { - z = z->parent; - left_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - right_rotate(T, z->parent->parent); - } - } else { - Node *y = z->parent->parent->left; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->left) { - z = z->parent; - right_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - left_rotate(T, z->parent->parent); - } - } - } - T->root->color = BLACK; -} - -void insert(RedBlackTree *T, int32_t key, enum Bool value) { - Node *z = (Node *)malloc(sizeof(Node)); - z->key = key; - z->value = value; - Node *y = T->nil; - Node *x = T->root; - while (x != T->nil) { - y = x; - if (z->key < x->key) { - x = x->left; - } else { - x = x->right; - } - } - z->parent = y; - if (y == T->nil) { - T->root = z; - } else if (z->key < y->key) { - y->left = z; - } else { - y->right = z; - } - z->left = T->nil; - z->right = T->nil; - z->color = RED; - insert_fixup(T, z); -} - -RedBlackTree *empty_rbtree() { - Node *nil = (Node *)malloc(sizeof(Node)); - nil->color = BLACK; - RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); - t->root = nil; - t->nil = nil; - return t; -} - -int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { - if (t == nil) { - return b; - } - int32_t left = fold(nil, t->left, b, f); - int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); - free(t); - return right; -} - -void make_tree_aux(int32_t n, RedBlackTree *t) { - if (n <= 0) return; - - int32_t n1 = n - 1; - insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); - make_tree_aux(n1, t); -} - -RedBlackTree *make_tree(int32_t n) { - RedBlackTree *t = empty_rbtree(); - make_tree_aux(n, t); - return t; -} - -int increment(int32_t k, enum Bool v, int32_t r) { - if(v == TRUE) { return r + 1; } else { return r; } -} - -void test(int n) { - int iter = 10000000 / MAX(n, 1); - int32_t acc = 0; - for(int i = 0; i < iter; i++) { - RedBlackTree *t = make_tree(n); - acc += fold(t->nil, t->root, 0, increment); - free(t->nil); - free(t); - } - printf("total: %d\n", acc); -} - -int main(int argc, char *argv[]) { - int n = 100; - if (argc > 1) { - n = atoi(argv[1]); - } - test(n); - return 0; -} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_full.c b/test/fip/src/rbtree/rbtree_clrs_full.c deleted file mode 100644 index 29cfe80b1..000000000 --- a/test/fip/src/rbtree/rbtree_clrs_full.c +++ /dev/null @@ -1,187 +0,0 @@ -// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein -// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. - -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -enum Color { RED, BLACK }; -enum Bool { TRUE, FALSE }; - -typedef struct Node { - int32_t key; - enum Bool value; - enum Color color; - struct Node *left; - struct Node *right; - struct Node *parent; -} Node; - -typedef struct RedBlackTree { - Node *nil; - Node *root; -} RedBlackTree; - -void left_rotate(RedBlackTree *T, Node *x) { - Node *y = x->right; - x->right = y->left; - if (y->left != T->nil) { - y->left->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->left) { - x->parent->left = y; - } else { - x->parent->right = y; - } - y->left = x; - x->parent = y; -} - -void right_rotate(RedBlackTree *T, Node *x) { - Node *y = x->left; - x->left = y->right; - if (y->right != T->nil) { - y->right->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->right) { - x->parent->right = y; - } else { - x->parent->left = y; - } - y->right = x; - x->parent = y; -} - -void insert_fixup(RedBlackTree *T, Node *z) { - while (z->parent->color == RED) { - if (z->parent == z->parent->parent->left) { - Node *y = z->parent->parent->right; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->right) { - z = z->parent; - left_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - right_rotate(T, z->parent->parent); - } - } else { - Node *y = z->parent->parent->left; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->left) { - z = z->parent; - right_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - left_rotate(T, z->parent->parent); - } - } - } - while(z->parent != T->nil) { - z = z->parent; - } - T->root->color = BLACK; -} - -void insert(RedBlackTree *T, int32_t key, enum Bool value) { - Node *z = (Node *)malloc(sizeof(Node)); - z->key = key; - z->value = value; - Node *y = T->nil; - Node *x = T->root; - while (x != T->nil) { - y = x; - if (z->key < x->key) { - x = x->left; - } else { - x = x->right; - } - } - z->parent = y; - if (y == T->nil) { - T->root = z; - } else if (z->key < y->key) { - y->left = z; - } else { - y->right = z; - } - z->left = T->nil; - z->right = T->nil; - z->color = RED; - insert_fixup(T, z); -} - -RedBlackTree *empty_rbtree() { - Node *nil = (Node *)malloc(sizeof(Node)); - nil->color = BLACK; - RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); - t->root = nil; - t->nil = nil; - return t; -} - -int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { - if (t == nil) { - return b; - } - int32_t left = fold(nil, t->left, b, f); - int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); - free(t); - return right; -} - -void make_tree_aux(int32_t n, RedBlackTree *t) { - if (n <= 0) return; - - int32_t n1 = n - 1; - insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); - make_tree_aux(n1, t); -} - -RedBlackTree *make_tree(int32_t n) { - RedBlackTree *t = empty_rbtree(); - make_tree_aux(n, t); - return t; -} - -int increment(int32_t k, enum Bool v, int32_t r) { - if(v == TRUE) { return r + 1; } else { return r; } -} - -void test(int n) { - int iter = 10000000 / MAX(n, 1); - int32_t acc = 0; - for(int i = 0; i < iter; i++) { - RedBlackTree *t = make_tree(n); - acc += fold(t->nil, t->root, 0, increment); - free(t->nil); - free(t); - } - printf("total: %d\n", acc); -} - -int main(int argc, char *argv[]) { - int n = 100; - if (argc > 1) { - n = atoi(argv[1]); - } - test(n); - return 0; -} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c b/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c deleted file mode 100644 index 8b313bf04..000000000 --- a/test/fip/src/rbtree/rbtree_clrs_full_mimalloc.c +++ /dev/null @@ -1,188 +0,0 @@ -// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein -// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. - -#include -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -enum Color { RED, BLACK }; -enum Bool { TRUE, FALSE }; - -typedef struct Node { - int32_t key; - enum Bool value; - enum Color color; - struct Node *left; - struct Node *right; - struct Node *parent; -} Node; - -typedef struct RedBlackTree { - Node *nil; - Node *root; -} RedBlackTree; - -void left_rotate(RedBlackTree *T, Node *x) { - Node *y = x->right; - x->right = y->left; - if (y->left != T->nil) { - y->left->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->left) { - x->parent->left = y; - } else { - x->parent->right = y; - } - y->left = x; - x->parent = y; -} - -void right_rotate(RedBlackTree *T, Node *x) { - Node *y = x->left; - x->left = y->right; - if (y->right != T->nil) { - y->right->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->right) { - x->parent->right = y; - } else { - x->parent->left = y; - } - y->right = x; - x->parent = y; -} - -void insert_fixup(RedBlackTree *T, Node *z) { - while (z->parent->color == RED) { - if (z->parent == z->parent->parent->left) { - Node *y = z->parent->parent->right; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->right) { - z = z->parent; - left_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - right_rotate(T, z->parent->parent); - } - } else { - Node *y = z->parent->parent->left; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->left) { - z = z->parent; - right_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - left_rotate(T, z->parent->parent); - } - } - } - while(z->parent != T->nil) { - z = z->parent; - } - T->root->color = BLACK; -} - -void insert(RedBlackTree *T, int32_t key, enum Bool value) { - Node *z = (Node *)mi_malloc(sizeof(Node)); - z->key = key; - z->value = value; - Node *y = T->nil; - Node *x = T->root; - while (x != T->nil) { - y = x; - if (z->key < x->key) { - x = x->left; - } else { - x = x->right; - } - } - z->parent = y; - if (y == T->nil) { - T->root = z; - } else if (z->key < y->key) { - y->left = z; - } else { - y->right = z; - } - z->left = T->nil; - z->right = T->nil; - z->color = RED; - insert_fixup(T, z); -} - -RedBlackTree *empty_rbtree() { - Node *nil = (Node *)mi_malloc(sizeof(Node)); - nil->color = BLACK; - RedBlackTree *t = (RedBlackTree *)mi_malloc(sizeof(RedBlackTree)); - t->root = nil; - t->nil = nil; - return t; -} - -int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { - if (t == nil) { - return b; - } - int32_t left = fold(nil, t->left, b, f); - int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); - mi_free(t); - return right; -} - -void make_tree_aux(int32_t n, RedBlackTree *t) { - if (n <= 0) return; - - int32_t n1 = n - 1; - insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); - make_tree_aux(n1, t); -} - -RedBlackTree *make_tree(int32_t n) { - RedBlackTree *t = empty_rbtree(); - make_tree_aux(n, t); - return t; -} - -int increment(int32_t k, enum Bool v, int32_t r) { - if(v == TRUE) { return r + 1; } else { return r; } -} - -void test(int n) { - int iter = 10000000 / MAX(n, 1); - int32_t acc = 0; - for(int i = 0; i < iter; i++) { - RedBlackTree *t = make_tree(n); - acc += fold(t->nil, t->root, 0, increment); - mi_free(t->nil); - mi_free(t); - } - printf("total: %d\n", acc); -} - -int main(int argc, char *argv[]) { - int n = 100; - if (argc > 1) { - n = atoi(argv[1]); - } - test(n); - return 0; -} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_clrs_mimalloc.c b/test/fip/src/rbtree/rbtree_clrs_mimalloc.c deleted file mode 100644 index 6e7ffb208..000000000 --- a/test/fip/src/rbtree/rbtree_clrs_mimalloc.c +++ /dev/null @@ -1,184 +0,0 @@ -// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein - -#include -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -enum Color { RED, BLACK }; -enum Bool { TRUE, FALSE }; - -typedef struct Node { - int32_t key; - enum Bool value; - enum Color color; - struct Node *left; - struct Node *right; - struct Node *parent; -} Node; - -typedef struct RedBlackTree { - Node *nil; - Node *root; -} RedBlackTree; - -void left_rotate(RedBlackTree *T, Node *x) { - Node *y = x->right; - x->right = y->left; - if (y->left != T->nil) { - y->left->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->left) { - x->parent->left = y; - } else { - x->parent->right = y; - } - y->left = x; - x->parent = y; -} - -void right_rotate(RedBlackTree *T, Node *x) { - Node *y = x->left; - x->left = y->right; - if (y->right != T->nil) { - y->right->parent = x; - } - y->parent = x->parent; - if (x->parent == T->nil) { - T->root = y; - } else if (x == x->parent->right) { - x->parent->right = y; - } else { - x->parent->left = y; - } - y->right = x; - x->parent = y; -} - -void insert_fixup(RedBlackTree *T, Node *z) { - while (z->parent->color == RED) { - if (z->parent == z->parent->parent->left) { - Node *y = z->parent->parent->right; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->right) { - z = z->parent; - left_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - right_rotate(T, z->parent->parent); - } - } else { - Node *y = z->parent->parent->left; - if (y->color == RED) { - z->parent->color = BLACK; - y->color = BLACK; - z->parent->parent->color = RED; - z = z->parent->parent; - } else { - if (z == z->parent->left) { - z = z->parent; - right_rotate(T, z); - } - z->parent->color = BLACK; - z->parent->parent->color = RED; - left_rotate(T, z->parent->parent); - } - } - } - T->root->color = BLACK; -} - -void insert(RedBlackTree *T, int32_t key, enum Bool value) { - Node *z = (Node *)mi_malloc(sizeof(Node)); - z->key = key; - z->value = value; - Node *y = T->nil; - Node *x = T->root; - while (x != T->nil) { - y = x; - if (z->key < x->key) { - x = x->left; - } else { - x = x->right; - } - } - z->parent = y; - if (y == T->nil) { - T->root = z; - } else if (z->key < y->key) { - y->left = z; - } else { - y->right = z; - } - z->left = T->nil; - z->right = T->nil; - z->color = RED; - insert_fixup(T, z); -} - -RedBlackTree *empty_rbtree() { - Node *nil = (Node *)mi_malloc(sizeof(Node)); - nil->color = BLACK; - RedBlackTree *t = (RedBlackTree *)mi_malloc(sizeof(RedBlackTree)); - t->root = nil; - t->nil = nil; - return t; -} - -int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { - if (t == nil) { - return b; - } - int32_t left = fold(nil, t->left, b, f); - int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); - mi_free(t); - return right; -} - -void make_tree_aux(int32_t n, RedBlackTree *t) { - if (n <= 0) return; - - int32_t n1 = n - 1; - insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); - make_tree_aux(n1, t); -} - -RedBlackTree *make_tree(int32_t n) { - RedBlackTree *t = empty_rbtree(); - make_tree_aux(n, t); - return t; -} - -int increment(int32_t k, enum Bool v, int32_t r) { - if(v == TRUE) { return r + 1; } else { return r; } -} - -void test(int n) { - int iter = 10000000 / MAX(n, 1); - int32_t acc = 0; - for(int i = 0; i < iter; i++) { - RedBlackTree *t = make_tree(n); - acc += fold(t->nil, t->root, 0, increment); - mi_free(t->nil); - mi_free(t); - } - printf("total: %d\n", acc); -} - -int main(int argc, char *argv[]) { - int n = 100; - if (argc > 1) { - n = atoi(argv[1]); - } - test(n); - return 0; -} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_cpp.cpp b/test/fip/src/rbtree/rbtree_cpp.cpp deleted file mode 100644 index fbc9b5927..000000000 --- a/test/fip/src/rbtree/rbtree_cpp.cpp +++ /dev/null @@ -1,64 +0,0 @@ -// Using standard STL to test the red-black tree in C++ -// In glibc++ this uses -// With the LLVM libc++ this uses -// In glibc this uses eventually: -// (Highly optimized in-place red-black tree using the low pointer bit to encode color information.) - -#include -#include -#include -using std::for_each; - -typedef int32_t nat; - -struct nat_lt_fn { - bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; } -}; - -typedef std::map map; - -map mk_map(unsigned n) { - map m; - while (n > 0) { - --n; - m.insert(std::make_pair(nat(n), n%10 == 0)); - } - return m; -} - -nat fold(map const & m) { - nat r(0); - for_each(m.begin(), m.end(), [&](std::pair const & p) { if (p.second) r = r + nat(1); }); - return r; -} - -/* -int main(int argc, char ** argv) { - unsigned n = 4200000; - if (argc == 2) { - n = atoi(argv[1]); - } - map m = mk_map(n); - std::cout << fold(m) << "\n"; - return 0; -} -*/ - -void test(int n) { - int iter = 10000000 / (n <= 0 ? 1 : n); - int32_t acc = 0; - for(int i = 0; i < iter; i++) { - map m = mk_map(n); - acc += fold(m); - } - printf("total: %d\n", acc); -} - -int main(int argc, char *argv[]) { - int n = 100; - if (argc > 1) { - n = atoi(argv[1]); - } - test(n); - return 0; -} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip.kk b/test/fip/src/rbtree/rbtree_fip.kk deleted file mode 100644 index ad21e327f..000000000 --- a/test/fip/src/rbtree/rbtree_fip.kk +++ /dev/null @@ -1,79 +0,0 @@ -import std/num/int32 -import std/os/env - -type any - Any - -type color - Red - Black - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf() - -type balance-node - Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - -type accum - Done - NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) - NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) - -fip fun rebuild(z : accum, t : tree) : tree - match z - NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) - NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) - Done -> t - -fip fun balance( z : accum, t : balance-node ) : tree - match t - Balance(_,l,k,v,r) -> - match z - NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) - NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) - Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) - Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) - Done -> Node(Black,l,k,v,r) - -fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree - match t - Node(c, l, kx, vx, r) - -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) - elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) - else rebuild(z, Node(c, l, kx, vx, r)) - Leaf -> balance(z, Balance(Black, Leaf, k, v, Leaf)) - -fip(1) fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v, Done) - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : pure tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : pure tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/rbtree/rbtree_fip_clrs.kk b/test/fip/src/rbtree/rbtree_fip_clrs.kk deleted file mode 100644 index 370801adc..000000000 --- a/test/fip/src/rbtree/rbtree_fip_clrs.kk +++ /dev/null @@ -1,91 +0,0 @@ -import std/num/int32 -import std/os/env - -type color - Red - Black - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf - -fip fun is-red(^t : tree) : bool - match t - Node(Red) -> True - _ -> False - -type accum - Done - NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) - NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) - -fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree - match t - Node(c, l, kx, vx, r) - -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) - elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) - else balance(z, Node(c, l, key, v, r)) - Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) - -fip fun set-black(t : tree) : tree - match t - Node(_, l, k, v, r) -> Node(Black, l, k, v, r) - t -> t - -fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating - match z - NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) - NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) - Done -> t - -fip fun balance( z : accum, t : tree ) : exn tree - match z - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> // black - if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) - else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) - NodeL(_,z2,k2,v2,r2) -> // black - if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) - else match t - Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) - Done -> Node(Black, l1, k1, v1, t) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeL(_,z2,k2,v2,r2) -> // black - if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) - else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) - NodeR(_,l2,k2,v2,z2) -> // black - if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) - else match t - Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) - Done -> Node(Black, t, k1, v1, r1) - z -> rebuild(z, t) - - -fip(1) fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v, Done) - - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : pure tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : pure tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_fip_icfp.kk b/test/fip/src/rbtree/rbtree_fip_icfp.kk deleted file mode 100644 index bec175dcc..000000000 --- a/test/fip/src/rbtree/rbtree_fip_icfp.kk +++ /dev/null @@ -1,77 +0,0 @@ -import std/num/int32 -import std/os/env - -ref type pad - Pad - -type color - Red - Black - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf() - -type reuse5 - Reuse5(a : color, b : pad, c : int32, d : bool, e : pad) - -type accum - Done - NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) - NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) - -fip fun rebuild(z : accum, t : tree) : tree - match z - NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) - NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) - Done -> t - -fip fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : reuse5 ) : tree - match z - NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) - NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) - NodeR(Red, l1, k1, v1, z1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) - Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) - NodeL(Red, z1, k1, v1, r1) -> match z1 - NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) - NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) - Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) - Done -> Node(Black,l,k,v,r) - -fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree - match t - Node(c, l, kx, vx, r) - -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) - elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) - else rebuild(z, Node(c, l, kx, vx, r)) - Leaf -> balance(z, Leaf, k, v, Leaf, Reuse5(Red,Pad,0.int32,True,Pad)) - -fip(1) fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v, Done) - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : pure tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : pure tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/rbtree/rbtree_std.kk b/test/fip/src/rbtree/rbtree_std.kk deleted file mode 100644 index f16c30227..000000000 --- a/test/fip/src/rbtree/rbtree_std.kk +++ /dev/null @@ -1,91 +0,0 @@ -// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean -import std/num/int32 -import std/os/env - -type color - Red - Black - - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf() - - -fun is-red(^t : tree) : bool - match t - Node(Red) -> True - _ -> False - - -fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree - match l - Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) - -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) - Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) - -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) - Node(_, lx, kx, vx, rx) - -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) - Leaf -> Leaf - - -fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree - match r - Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) - -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) - Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) - -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) - Node(_, lx, kx, vx, rx) - -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) - Leaf -> Leaf - - -fun ins(t : tree, k : int32, v : bool) : tree - match t - Node(Red, l, kx, vx, r) - -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) - elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) - else Node(Red, l, k, v, r) - Node(Black, l, kx, vx, r) - -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) - else Node(Black, ins(l, k, v), kx, vx, r)) - elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) - else Node(Black, l, kx, vx, ins(r, k, v))) - else Node(Black, l, k, v, r) - Leaf -> Node(Red, Leaf, k, v, Leaf) - - -fun set-black(t : tree) : tree - match t - Node(_, l, k, v, r) -> Node(Black, l, k, v, r) - _ -> t - - -fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v).set-black - - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : div tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : div tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree_std_noreuse.kk b/test/fip/src/rbtree/rbtree_std_noreuse.kk deleted file mode 100644 index f16c30227..000000000 --- a/test/fip/src/rbtree/rbtree_std_noreuse.kk +++ /dev/null @@ -1,91 +0,0 @@ -// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean -import std/num/int32 -import std/os/env - -type color - Red - Black - - -type tree - Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) - Leaf() - - -fun is-red(^t : tree) : bool - match t - Node(Red) -> True - _ -> False - - -fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree - match l - Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) - -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) - Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) - -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) - Node(_, lx, kx, vx, rx) - -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) - Leaf -> Leaf - - -fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree - match r - Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) - -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) - Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) - -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) - Node(_, lx, kx, vx, rx) - -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) - Leaf -> Leaf - - -fun ins(t : tree, k : int32, v : bool) : tree - match t - Node(Red, l, kx, vx, r) - -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) - elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) - else Node(Red, l, k, v, r) - Node(Black, l, kx, vx, r) - -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) - else Node(Black, ins(l, k, v), kx, vx, r)) - elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) - else Node(Black, l, kx, vx, ins(r, k, v))) - else Node(Black, l, k, v, r) - Leaf -> Node(Red, Leaf, k, v, Leaf) - - -fun set-black(t : tree) : tree - match t - Node(_, l, k, v, r) -> Node(Black, l, k, v, r) - _ -> t - - -fun insert(t : tree, k : int32, v : bool) : tree - ins(t, k, v).set-black - - -fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a - match t - Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) - Leaf -> b - - -fun make-tree-aux(n : int32, t : tree) : div tree - if n <= zero then t else - val n1 = n.dec - make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) - -pub fun make-tree(n : int32) : div tree - make-tree-aux(n, Leaf) - - -fun test(n : int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val t = make-tree(n) - acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_merge_fip.kk b/test/fip/src/sort/sort_merge_fip.kk deleted file mode 100644 index 8b0f077b7..000000000 --- a/test/fip/src/sort/sort_merge_fip.kk +++ /dev/null @@ -1,133 +0,0 @@ -// Haskell's Data.List.sort function ported to Koka -import std/num/int32 -import std/os/env - -alias elem = int32 - -ref type pad - Pad - -type unit2 - Unit2(a : pad, b : pad) - -type pair - Pair(a : a, b : a) - -type sublist - SCons(a : a, cs : sublist) - STuple(a : a, b : a) - -type partition - Sublist(c : sublist, z : partition) - Singleton(c : a, z : partition) - End - -fip fun reverse-go(c : sublist, acc : sublist, u : unit2) : sublist - match c - SCons(a, cs) -> reverse-go(cs, SCons(a, acc), u) - STuple(a, b) -> SCons(b, SCons(a, acc)) - -fip fun reverse-sublist(c : sublist) : sublist - match c - SCons(a, SCons(b, c)) -> reverse-go(c, STuple(b, a), Unit2(Pad,Pad)) - SCons(a, STuple(b, c)) -> SCons(c, STuple(b, a)) - STuple(a, b) -> STuple(b, a) - -fip fun sequences(xs : list) : div partition - match(xs) - Cons(a, Cons(b, xs1)) -> if(a > b) - then - val (sublist, bs) = descending(b, STuple(b, a), xs1) - Sublist(sublist, sequences(bs)) - else - val (sublist, bs) = ascending(b, STuple(b, a), xs1) - Sublist(sublist, sequences(bs)) - Cons(a, Nil) -> Singleton(a, End) - Nil -> End - -fip fun descending(a : elem, sublist : sublist, bs : list) : (sublist, list) - match(bs) - Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1) - bs -> (sublist, bs) - -fip fun ascending(a : elem, sublist : sublist, bs : list) : (sublist, list) - match(bs) - Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1) - bs -> (reverse-sublist(sublist), bs) - -fip fun to-list(c : sublist, u : unit2) : list - match c - SCons(a, cs) -> Cons(a, to-list(cs, u)) - STuple(a, b) -> Cons(a, Cons(b, Nil)) - -fip fun merge-all(xs : partition) :
list - match(xs) - Sublist(x, End) -> to-list(x, Unit2(Pad,Pad)) - Singleton(x, End) -> Cons(x, Nil) - xs -> merge-all(merge-pairs(xs)) - -fip fun merge-pairs(xs : partition) :
partition - match(xs) - Sublist(a, Sublist(b, xs1)) -> Sublist(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Sublist(a, Singleton(b, xs1)) -> Sublist(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Singleton(a, Sublist(b, xs1)) -> Sublist(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) - Singleton(a, Singleton(b, xs1)) -> - Sublist(if a <= b then STuple(a, b) else STuple(b, a), merge-pairs(xs1)) - xs -> xs - -fip fun merge(c1 : sublist, c2 : sublist, u : unit2) :
sublist - match c1 - SCons(a, cs1) -> match c2 - SCons(b, cs2) -> - if a <= b then SCons(a, merge(cs1, SCons(b, cs2), u)) - else SCons(b, merge(SCons(a, cs1), cs2, u)) - STuple(b, c) -> - if a <= b then SCons(a, merge(cs1, STuple(b, c), u)) - else SCons(b, merge-last-left(SCons(a, cs1), c, u)) - STuple(a, b) -> match c2 - SCons(c, cs2) -> - if a <= c then SCons(a, merge-last-right(b, SCons(c, cs2), u)) - else SCons(c, merge(STuple(a, b), cs2, u)) - STuple(c, d) -> - if a <= c then SCons(a, merge-right(b, Pair(c, d), u)) - else SCons(c, merge-left(Pair(a, b), d, u)) - -fip fun merge-last-right(a : elem, c2 : sublist, u : unit2) : sublist - match c2 - SCons(b, cs2) | a <= b -> SCons(a, SCons(b, cs2)) - | _ -> SCons(b, merge-last-right(a, cs2, u)) - STuple(b, c) -> merge-right(a, Pair(b, c), u) - -fip fun merge-last-left(c2 : sublist, d : elem, u : unit2) : sublist - match c2 - SCons(a, cs2) | a <= d -> SCons(a, merge-last-left(cs2, d, u)) - | _ -> SCons(d, SCons(a, cs2)) - STuple(a, b) -> merge-left(Pair(a, b), d, u) - -fip fun merge-right(a : elem, p : pair, u : unit2) : sublist - match p - Pair(b, c) | a <= b -> SCons(a, STuple(b, c)) - | _ -> SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) - -fip fun merge-left(p : pair, d : elem, u : unit2) : sublist - match p - Pair(a, b) | a <= d -> SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) - | _ -> SCons(d, STuple(a, b)) - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = merge-all(sequences(xs)) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/sort/sort_merge_std.kk b/test/fip/src/sort/sort_merge_std.kk deleted file mode 100644 index 9fcb70ca7..000000000 --- a/test/fip/src/sort/sort_merge_std.kk +++ /dev/null @@ -1,58 +0,0 @@ -// Haskell's Data.List.sort function ported to Koka -import std/num/int32 -import std/os/env - -alias elem = int32 - -fun sequences(xs : list) :
list> - match(xs) - Cons(a, Cons(b, xs1)) -> - if(a > b) then descending(b, Cons(a, Nil), xs1) - else ascending(b, Cons(a, Nil), xs1) - _ -> Cons(xs, Nil) - -fun descending(a : elem, chain : list, bs : list) :
list> - match(bs) - Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) - _ -> Cons(Cons(a, chain), sequences(bs)) - -fun ascending(a : elem, chain : list, bs : list) :
list> - match(bs) - Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) - _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) - -fun merge-all(xs : list>) :
list - match xs - Cons(x, Nil) -> x - _ -> merge-all(merge-pairs(xs)) - -fun merge-pairs(xs : list>) :
list> - match xs - Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) - _ -> xs - -fun merge(xs : list, ys : list) :
list - match(xs, ys) - (Cons(x, xx), Cons(y, yy)) -> - if(x > y) then Cons(y, merge(xs, yy)) - else Cons(x, merge(xx, ys)) - (Cons(_, _), Nil) -> xs - (_, _) -> ys - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = merge-all(sequences(xs)) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_merge_std_noreuse.kk b/test/fip/src/sort/sort_merge_std_noreuse.kk deleted file mode 100644 index 9fcb70ca7..000000000 --- a/test/fip/src/sort/sort_merge_std_noreuse.kk +++ /dev/null @@ -1,58 +0,0 @@ -// Haskell's Data.List.sort function ported to Koka -import std/num/int32 -import std/os/env - -alias elem = int32 - -fun sequences(xs : list) :
list> - match(xs) - Cons(a, Cons(b, xs1)) -> - if(a > b) then descending(b, Cons(a, Nil), xs1) - else ascending(b, Cons(a, Nil), xs1) - _ -> Cons(xs, Nil) - -fun descending(a : elem, chain : list, bs : list) :
list> - match(bs) - Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) - _ -> Cons(Cons(a, chain), sequences(bs)) - -fun ascending(a : elem, chain : list, bs : list) :
list> - match(bs) - Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) - _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) - -fun merge-all(xs : list>) :
list - match xs - Cons(x, Nil) -> x - _ -> merge-all(merge-pairs(xs)) - -fun merge-pairs(xs : list>) :
list> - match xs - Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) - _ -> xs - -fun merge(xs : list, ys : list) :
list - match(xs, ys) - (Cons(x, xx), Cons(y, yy)) -> - if(x > y) then Cons(y, merge(xs, yy)) - else Cons(x, merge(xx, ys)) - (Cons(_, _), Nil) -> xs - (_, _) -> ys - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = merge-all(sequences(xs)) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_quick_fip.kk b/test/fip/src/sort/sort_quick_fip.kk deleted file mode 100644 index d7f94c3c3..000000000 --- a/test/fip/src/sort/sort_quick_fip.kk +++ /dev/null @@ -1,97 +0,0 @@ -import std/num/int32 -import std/os/env - -alias elem = int32 - -ref type pad - Pad - -ref type unit2 - Unit2(a : pad, b : pad) - -type maybe2 - Nothing2 - Just2(a : a, b : pad) - -type sublist - SCons(a : a, cs : sublist) - STuple(a : a, b : a) - -type partition - Sublist(c : sublist, bdl : partition) - Singleton(c : a, bdl : partition) - End - -fip fun quicksort(xs : list) : div list - quicksort-go(xs, End) - -fip fun quicksort-go(xs : list, b : partition) : div list - match xs - Cons(p, xx) -> - val (lo, hi) = split-list(p, xx, Done, b, Unit2(Pad,Pad)) - quicksort-go(lo, hi) - Nil -> quicksort-app(b) - -fip fun quicksort-app(bdl : partition) : div list - match bdl - Singleton(p, b) -> Cons(p,quicksort-app(b)) - Sublist(xs, bdl') -> match xs - SCons(p, xx) -> - val (lo, hi) = split-sublist(p, xx, Done, bdl', Unit2(Pad,Pad), Unit2(Pad,Pad)) - quicksort-go(lo, hi) - STuple(a, b) | a <= b -> Cons(a, Cons(b, quicksort-app(bdl'))) - | _ -> Cons(b, Cons(a, quicksort-app(bdl'))) - End -> Nil - -type accum - MkLo(x : a, k : accum) - MkHi(x : a, k : accum) - Done - -fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) - match xs - Cons(x, xx) | x < p -> split-list(p, xx, MkLo(x, k), b, u) - | _ -> split-list(p, xx, MkHi(x, k), b, u) - Nil -> - val (lo, hi) = split-app1(k, Nil, Nothing2, b) - (lo, Singleton(p, hi)) - -fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) - match xs - SCons(x, xx) | x < p -> split-sublist(p, xx, MkLo(x, k), b, u, u1) - | _ -> split-sublist(p, xx, MkHi(x, k), b, u, u1) - STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) - -fip fun split-app1(k : accum, lo : list, hi : maybe2, b : partition) :
(list, partition) - match k - MkLo(x, k) -> split-app1(k, Cons(x, lo), hi, b) - MkHi(x, k) -> match hi - Nothing2 -> split-app1(k, lo, Just2(x, Pad), b) - Just2(y, _) -> split-app2(k, lo, STuple(y,x), b, Unit2(Pad,Pad)) - Done -> match hi - Just2(x, _) -> (lo, Singleton(x, b)) - Nothing2 -> (lo, b) - -fip fun split-app2(k : accum, lo : list, hi : sublist, b : partition, u : unit2) : (list, partition) - match k - MkLo(x, k) -> split-app2(k, Cons(x,lo), hi, b, u) - MkHi(x, k) -> split-app2(k, lo, SCons(x,hi), b, u) - Done -> (lo, Sublist(hi, b)) - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = quicksort(xs) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/sort/sort_quick_std.kk b/test/fip/src/sort/sort_quick_std.kk deleted file mode 100644 index 9c62aaf35..000000000 --- a/test/fip/src/sort/sort_quick_std.kk +++ /dev/null @@ -1,40 +0,0 @@ -import std/num/int32 -import std/os/env - -alias elem = int32 - -fun quicksort(xs : list, res : list) : list - match(xs) - Cons(x, xx) -> - val (lo, hi) = partition(x, xx) - quicksort(lo, Cons(x, quicksort(hi, res))) - Nil -> res - -fun partition(^x : elem, ys : list) - match(ys) - Cons(y, yy) -> - if(y < x) then - val (lo, hi) = partition(x, yy) - (Cons(y, lo), hi) - else - val (lo, hi) = partition(x, yy) - (lo, Cons(y, hi)) - Nil -> (Nil, Nil) - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = quicksort(xs, Nil) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/sort/sort_quick_std_noreuse.kk b/test/fip/src/sort/sort_quick_std_noreuse.kk deleted file mode 100644 index 9c62aaf35..000000000 --- a/test/fip/src/sort/sort_quick_std_noreuse.kk +++ /dev/null @@ -1,40 +0,0 @@ -import std/num/int32 -import std/os/env - -alias elem = int32 - -fun quicksort(xs : list, res : list) : list - match(xs) - Cons(x, xx) -> - val (lo, hi) = partition(x, xx) - quicksort(lo, Cons(x, quicksort(hi, res))) - Nil -> res - -fun partition(^x : elem, ys : list) - match(ys) - Cons(y, yy) -> - if(y < x) then - val (lo, hi) = partition(x, yy) - (Cons(y, lo), hi) - else - val (lo, hi) = partition(x, yy) - (lo, Cons(y, hi)) - Nil -> (Nil, Nil) - -fun rand-list(n : int32, seed : int32) :
list - val a = 22695477.int32 - val c = 1.int32 - val next = a * seed + c - if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) - else Nil - -fun test(n : int32) - val xs = rand-list(n, 13.int32) - val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - val ys = quicksort(xs, Nil) - acc + ys.last(0.int32) - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip.c b/test/fip/src/tmap/tmap_fip.c deleted file mode 100644 index b30e2754d..000000000 --- a/test/fip/src/tmap/tmap_fip.c +++ /dev/null @@ -1,101 +0,0 @@ -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -struct node { - int32_t header; - int32_t data; - struct node* left; - struct node* right; -}; - -struct node* create_node(int32_t data) { - struct node* new_node = (struct node*)malloc(sizeof(struct node)); - new_node->header = 0; - new_node->data = data; - new_node->left = NULL; - new_node->right = NULL; - return new_node; -} - -struct node* insert_range(int32_t start, int32_t end) { - if (start > end) return NULL; - - int32_t mid = start + (end - start) / 2; - struct node* root = create_node(mid); - - root->left = insert_range(start, mid - 1); - root->right = insert_range(mid + 1, end); - - return root; -} - -int sum_tree(struct node* root) { - if (root == NULL) return 0; - - int n = root->data + sum_tree(root->left) + sum_tree(root->right); - free(root); - return n; -} - -struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { - struct node* acc = NULL; - - acc: - while(root != NULL) { - struct node* acc_ = create_node(root->data); - acc_->left = acc; - acc_->right = root->right; - root = root->left; - acc = acc_; - } - - app: - if(acc == NULL) return root; - if(acc->header == 0) { - struct node* right = acc->right; - acc->header = 1; - acc->data = f(acc->data); - acc->right = acc->left; - acc->left = root; - root = right; - goto acc; - } else { // acc->header == 1 - struct node* acc_ = acc->right; - acc->right = root; - root = acc; - acc = acc_; - goto app; - } -} - -int increment(int x){ - return x+1; -} - -void test(int n) { - struct node* xs = insert_range(1, n); - int iter = 100000000 / MAX(n, 1); - int32_t x = 0; - - for(int i = 0; i < iter; i++) { - x += sum_tree(tmap(xs, increment)); - } - sum_tree(xs); // free xs - - printf("total: %d\n", x); -} - -int main(int argc, char* argv[]) { - int n; - if (argc < 2) { - printf("Please provide a natural number as an argument.\n"); - return 0; - } else { - n = atoi(argv[1]); - } - - test(n); - - return 0; -} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip.kk b/test/fip/src/tmap/tmap_fip.kk deleted file mode 100644 index 861765715..000000000 --- a/test/fip/src/tmap/tmap_fip.kk +++ /dev/null @@ -1,47 +0,0 @@ -import std/num/int32 -import std/os/env - -type tree - Leaf - Bin(l : tree, a : a, r : tree) - -fun tree32(lo : int32, hi : int32) - if lo > hi then Leaf - else - val mi = lo + (hi - lo) / 2.int32 - Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) - -fun tsum32_go(t, acc : int32) - match t - Leaf -> acc - Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) - -fun tsum32(t0 : tree) - tsum32_go(t0, 0.int32) - -type accum - Hole - BinR(k : accum, x : a, r : tree) - BinL(l : tree, x : b, k : accum) - -fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree - match t - Leaf -> tmap-app( k, f, Leaf ) - Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) - -fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree - match k0 - BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) - BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) - Hole -> t - -fun test(n : int32) - val xs = tree32(1.int32,n) - val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 - println("total: " ++ x.show) - - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/tmap/tmap_fip_mimalloc.c b/test/fip/src/tmap/tmap_fip_mimalloc.c deleted file mode 100644 index 2a8516b61..000000000 --- a/test/fip/src/tmap/tmap_fip_mimalloc.c +++ /dev/null @@ -1,102 +0,0 @@ -#include -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -struct node { - int32_t header; - int32_t data; - struct node* left; - struct node* right; -}; - -struct node* create_node(int32_t data) { - struct node* new_node = (struct node*)mi_malloc(sizeof(struct node)); - new_node->header = 0; - new_node->data = data; - new_node->left = NULL; - new_node->right = NULL; - return new_node; -} - -struct node* insert_range(int32_t start, int32_t end) { - if (start > end) return NULL; - - int32_t mid = start + (end - start) / 2; - struct node* root = create_node(mid); - - root->left = insert_range(start, mid - 1); - root->right = insert_range(mid + 1, end); - - return root; -} - -int sum_tree(struct node* root) { - if (root == NULL) return 0; - - int n = root->data + sum_tree(root->left) + sum_tree(root->right); - mi_free(root); - return n; -} - -struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { - struct node* acc = NULL; - - acc: - while(root != NULL) { - struct node* acc_ = create_node(root->data); - acc_->left = acc; - acc_->right = root->right; - root = root->left; - acc = acc_; - } - - app: - if(acc == NULL) return root; - if(acc->header == 0) { - struct node* right = acc->right; - acc->header = 1; - acc->data = f(acc->data); - acc->right = acc->left; - acc->left = root; - root = right; - goto acc; - } else { // acc->header == 1 - struct node* acc_ = acc->right; - acc->right = root; - root = acc; - acc = acc_; - goto app; - } -} - -int increment(int x){ - return x+1; -} - -void test(int n) { - struct node* xs = insert_range(1, n); - int iter = 100000000 / MAX(n, 1); - int32_t x = 0; - - for(int i = 0; i < iter; i++) { - x += sum_tree(tmap(xs, increment)); - } - sum_tree(xs); // free xs - - printf("total: %d\n", x); -} - -int main(int argc, char* argv[]) { - int n; - if (argc < 2) { - printf("Please provide a natural number as an argument.\n"); - return 0; - } else { - n = atoi(argv[1]); - } - - test(n); - - return 0; -} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_fip_noreuse.kk b/test/fip/src/tmap/tmap_fip_noreuse.kk deleted file mode 100644 index 861765715..000000000 --- a/test/fip/src/tmap/tmap_fip_noreuse.kk +++ /dev/null @@ -1,47 +0,0 @@ -import std/num/int32 -import std/os/env - -type tree - Leaf - Bin(l : tree, a : a, r : tree) - -fun tree32(lo : int32, hi : int32) - if lo > hi then Leaf - else - val mi = lo + (hi - lo) / 2.int32 - Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) - -fun tsum32_go(t, acc : int32) - match t - Leaf -> acc - Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) - -fun tsum32(t0 : tree) - tsum32_go(t0, 0.int32) - -type accum - Hole - BinR(k : accum, x : a, r : tree) - BinL(l : tree, x : b, k : accum) - -fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree - match t - Leaf -> tmap-app( k, f, Leaf ) - Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) - -fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree - match k0 - BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) - BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) - Hole -> t - -fun test(n : int32) - val xs = tree32(1.int32,n) - val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 - println("total: " ++ x.show) - - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/tmap/tmap_std.c b/test/fip/src/tmap/tmap_std.c deleted file mode 100644 index 520951f78..000000000 --- a/test/fip/src/tmap/tmap_std.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -struct node { - int32_t data; - struct node* left; - struct node* right; -}; - -struct node* create_node(int32_t data) { - struct node* new_node = (struct node*)malloc(sizeof(struct node)); - new_node->data = data; - new_node->left = NULL; - new_node->right = NULL; - return new_node; -} - -struct node* insert_range(int32_t start, int32_t end) { - if (start > end) return NULL; - - int32_t mid = start + (end - start) / 2; - struct node* root = create_node(mid); - - root->left = insert_range(start, mid - 1); - root->right = insert_range(mid + 1, end); - - return root; -} - -int sum_tree(struct node* root) { - if (root == NULL) return 0; - - int n = root->data + sum_tree(root->left) + sum_tree(root->right); - free(root); - return n; -} - -void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { - while(root != NULL) { - struct node* root_ = create_node(root->data); - tmap(root->left, f, &root_->left); - root_->data = f(root_->data); - *dest = root_; - dest = &root_->right; - root = root->right; - } - *dest = NULL; -} - -int increment(int x){ - return x+1; -} - -void test(int n) { - struct node* xs = insert_range(1, n); - int iter = 100000000 / MAX(n, 1); - int32_t x = 0; - - for(int i = 0; i < iter; i++) { - struct node* ys; - tmap(xs, increment, &ys); - x += sum_tree(ys); - } - sum_tree(xs); // free xs - - printf("total: %d\n", x); -} - -int main(int argc, char* argv[]) { - int n; - if (argc < 2) { - printf("Please provide a natural number as an argument.\n"); - return 0; - } else { - n = atoi(argv[1]); - } - - test(n); - - return 0; -} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_std.kk b/test/fip/src/tmap/tmap_std.kk deleted file mode 100644 index e41f79750..000000000 --- a/test/fip/src/tmap/tmap_std.kk +++ /dev/null @@ -1,34 +0,0 @@ -import std/num/int32 -import std/os/env - -type tree - Leaf - Bin(l : tree, a : a, r : tree) - -fun tree32(lo : int32, hi : int32) - if lo > hi then Leaf - else - val mi = lo + (hi - lo) / 2.int32 - Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) - -fun tsum32(t0 : tree) - fun go(t, acc : int32) - match t - Leaf -> acc - Bin(l, a, r) -> go(r, go(l, acc + a)) - go(t0, 0.int32) - -fun tmap-std( xs : tree, f : a -> e b ) : e tree - match xs - Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) - Leaf -> Leaf - -fun test(n : int32) - val xs = tree32(1.int32,n) - val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - acc + xs.tmap-std(fn(x) x.inc).tsum32 - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) diff --git a/test/fip/src/tmap/tmap_std_mimalloc.c b/test/fip/src/tmap/tmap_std_mimalloc.c deleted file mode 100644 index 4428f4242..000000000 --- a/test/fip/src/tmap/tmap_std_mimalloc.c +++ /dev/null @@ -1,83 +0,0 @@ -#include -#include -#include -#define MAX(a,b) (((a)>(b))?(a):(b)) - -struct node { - int32_t data; - struct node* left; - struct node* right; -}; - -struct node* create_node(int32_t data) { - struct node* new_node = (struct node*)mi_malloc(sizeof(struct node)); - new_node->data = data; - new_node->left = NULL; - new_node->right = NULL; - return new_node; -} - -struct node* insert_range(int32_t start, int32_t end) { - if (start > end) return NULL; - - int32_t mid = start + (end - start) / 2; - struct node* root = create_node(mid); - - root->left = insert_range(start, mid - 1); - root->right = insert_range(mid + 1, end); - - return root; -} - -int sum_tree(struct node* root) { - if (root == NULL) return 0; - - int n = root->data + sum_tree(root->left) + sum_tree(root->right); - mi_free(root); - return n; -} - -void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { - while(root != NULL) { - struct node* root_ = create_node(root->data); - tmap(root->left, f, &root_->left); - root_->data = f(root_->data); - *dest = root_; - dest = &root_->right; - root = root->right; - } - *dest = NULL; -} - -int increment(int x){ - return x+1; -} - -void test(int n) { - struct node* xs = insert_range(1, n); - int iter = 100000000 / MAX(n, 1); - int32_t x = 0; - - for(int i = 0; i < iter; i++) { - struct node* ys; - tmap(xs, increment, &ys); - x += sum_tree(ys); - } - sum_tree(xs); // free xs - - printf("total: %d\n", x); -} - -int main(int argc, char* argv[]) { - int n; - if (argc < 2) { - printf("Please provide a natural number as an argument.\n"); - return 0; - } else { - n = atoi(argv[1]); - } - - test(n); - - return 0; -} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap_std_noreuse.kk b/test/fip/src/tmap/tmap_std_noreuse.kk deleted file mode 100644 index e41f79750..000000000 --- a/test/fip/src/tmap/tmap_std_noreuse.kk +++ /dev/null @@ -1,34 +0,0 @@ -import std/num/int32 -import std/os/env - -type tree - Leaf - Bin(l : tree, a : a, r : tree) - -fun tree32(lo : int32, hi : int32) - if lo > hi then Leaf - else - val mi = lo + (hi - lo) / 2.int32 - Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) - -fun tsum32(t0 : tree) - fun go(t, acc : int32) - match t - Leaf -> acc - Bin(l, a, r) -> go(r, go(l, acc + a)) - go(t0, 0.int32) - -fun tmap-std( xs : tree, f : a -> e b ) : e tree - match xs - Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) - Leaf -> Leaf - -fun test(n : int32) - val xs = tree32(1.int32,n) - val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) - acc + xs.tmap-std(fn(x) x.inc).tsum32 - println("total: " ++ x.show) - -fun main() - val n = get-args().head("").parse-int.default(100).int32 - test(n) From 17064da1842bb978cd57df23e8070efd30f15eda Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 10:03:30 -0700 Subject: [PATCH 171/233] fix linking with mimalloc --- test/fip/bench.sh | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index b53e44e42..685b61cc3 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -1,12 +1,13 @@ # -runparams="10000" # "1 10 100 1000 10000 100000 1000000" +runparams="100000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" dirs="tmap rbtree finger sort" +# note: order matters as it is made relative to the first benches_tmapkk="tmap/tmap-std.kk tmap/tmap-fip.kk" benches_tmapc="tmap/tmap-std.c tmap/tmap-fip.c" -benches_rbtreekk="rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std.kk rbtree/rbtree-fip.kk rbtree/rbtree-fip-clrs.kk" +benches_rbtreekk="rbtree/rbtree-std.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-fip.kk rbtree/rbtree-fip-clrs.kk" benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" benches_sortkk="sort/msort-std.kk sort/msort-fip.kk sort/qsort-std.kk sort/qsort-fip.kk" benches_fingerkk="finger/ftree-std.kk finger/ftree-fip.kk" @@ -40,8 +41,7 @@ copts="" cppoutdir=".koka/cppcomp" cppopts="" -mimalloc="mimalloc-2.1" -mimalloc_usr_local="/usr/local/" +mimalloc_o="/usr/local/lib/mimalloc-2.1/mimalloc.o" gtime="/usr/bin/time" if command -v "gtime"; then @@ -165,7 +165,7 @@ function expand_benches { for bench in $benches; do local base=${bench%.*} if [[ $bench == *-std\.kk ]]; then - newb="$newb $bench $base-noreuse.kk" + newb="$newb $base-noreuse.kk $bench" # order matters: no relative to std-noreuse elif [[ $bench == *\.c ]]; then newb="$newb $bench $base-mi.c" elif [[ $bench == *\.cpp ]]; then @@ -212,7 +212,7 @@ function build_c { # options="$options -march=native" fi if [[ "$1" == *"-mi"* ]]; then - options="$options -L ${mimalloc_usr_local}lib/$mimalloc -I ${mimalloc_usr_local}include/$mimalloc -lmimalloc" + options="$options $mimalloc_o -I ${mimalloc_usr_local}include/$mimalloc" srcname="${1%-mi.c}.c" fi if ! [ -f "$benchdir/$srcname" ]; then @@ -236,7 +236,7 @@ function build_cpp { # options="$options -march=native" fi if [[ "$1" == *"-mi"* ]]; then - options="$options -L ${mimalloc_usr_local}lib/$mimalloc -I ${mimalloc_usr_local}include/$mimalloc -lmimalloc" + options="$options $mimalloc_o -I ${mimalloc_usr_local}include/$mimalloc" srcname="${1%-mi.cpp}.cpp" fi if ! [ -f "$benchdir/$srcname" ]; then @@ -524,4 +524,5 @@ fi if [ "$do_graph" = "yes" ]; then graph_all + #xgraph_all fi From 588a6cc4395d06dfb79d3d7128d00b297e51e99f Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 10:27:33 -0700 Subject: [PATCH 172/233] fix avg calculation --- test/fip/bench.sh | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 685b61cc3..ed28c359b 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -2,7 +2,7 @@ # runparams="100000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" -dirs="tmap rbtree finger sort" +benchmarks="tmap rbtree ftree msort qsort" # note: order matters as it is made relative to the first benches_tmapkk="tmap/tmap-std.kk tmap/tmap-fip.kk" @@ -314,7 +314,7 @@ function run_all { basetime="" -function avg { #bname log logbench $4= map +function avg { #$1=bname $2=log $3=logbench $4= $5=benchname $6= $7= local median="0.01" local stddev="0" local rss="0" @@ -344,19 +344,19 @@ function avg_all { local logbench="./log/avg.txt" rm -f $logbench 2> /dev/null echo "# benchmark variant param elapsed relative stddev rss" >> $logbench - for dir in $dirs; do + for benchmark in $benchmarks; do for runparam in $runparams; do - basetime="" + basetime="" for bench in $benches; do local prefix=${bench#*\.} local base=${bench%\.*} # no extension local stem=${base##*/} - local bdir=$(echo $base | cut -d'/' -f 1) + # local bdir=$(echo $base | cut -d'/' -f 1) local variant=${stem#*-} - local bname="${prefix}__${stem}__${runparam}" - local log="./log/$bname.txt" - if [ "$dir" = "$bdir" ]; then - avg $bname $log $logbench $prefix $dir $variant $runparam + local label="${prefix}__${stem}__${runparam}" + local log="./log/$label.txt" + if [ "$benchmark" = "${stem%%-*}" ]; then + avg $label $log $logbench $prefix $stem $variant $runparam fi done echo "##" >> $logbench From 686010447c1d732fbf05f188477b90d161caad83 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 10:29:59 -0700 Subject: [PATCH 173/233] fix bench name in avg --- test/fip/bench.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index ed28c359b..0c8d76477 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -353,10 +353,11 @@ function avg_all { local stem=${base##*/} # local bdir=$(echo $base | cut -d'/' -f 1) local variant=${stem#*-} + local bname=${stem%%-*} local label="${prefix}__${stem}__${runparam}" local log="./log/$label.txt" - if [ "$benchmark" = "${stem%%-*}" ]; then - avg $label $log $logbench $prefix $stem $variant $runparam + if [ "$benchmark" = "$bname" ]; then + avg $label $log $logbench $prefix $bname $variant $runparam fi done echo "##" >> $logbench From e47e9921d7a392a9821b7b6c2e6c86fd4a877012 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 10:41:43 -0700 Subject: [PATCH 174/233] make relative to fip instead of std --- test/fip/bench.sh | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 0c8d76477..084634e61 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -5,12 +5,12 @@ runparams_small="1 10 100 1000" benchmarks="tmap rbtree ftree msort qsort" # note: order matters as it is made relative to the first -benches_tmapkk="tmap/tmap-std.kk tmap/tmap-fip.kk" -benches_tmapc="tmap/tmap-std.c tmap/tmap-fip.c" -benches_rbtreekk="rbtree/rbtree-std.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-fip.kk rbtree/rbtree-fip-clrs.kk" +benches_tmapkk="tmap/tmap-fip.kk tmap/tmap-std.kk" +benches_tmapc="tmap/tmap-fip.c tmap/tmap-std.c" +benches_rbtreekk="rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std.kk rbtree/rbtree-fip-clrs.kk" benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" -benches_sortkk="sort/msort-std.kk sort/msort-fip.kk sort/qsort-std.kk sort/qsort-fip.kk" -benches_fingerkk="finger/ftree-std.kk finger/ftree-fip.kk" +benches_sortkk="sort/msort-fip.kk sort/msort-std.kk sort/qsort-fip.kk sort/qsort-std.kk" +benches_fingerkk="finger/ftree-fip.kk finger/ftree-std.kk" benches_all="$benches_tmapkk $benches_tmapc $benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk" # get this by running `stack path | grep local-install-root`` in the koka development directory @@ -165,7 +165,7 @@ function expand_benches { for bench in $benches; do local base=${bench%.*} if [[ $bench == *-std\.kk ]]; then - newb="$newb $base-noreuse.kk $bench" # order matters: no relative to std-noreuse + newb="$newb $bench $base-noreuse.kk" # order matters elif [[ $bench == *\.c ]]; then newb="$newb $bench $base-mi.c" elif [[ $bench == *\.cpp ]]; then From 5c44f42d3437bb518f8e3af530031dbf3fbc7dff Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 12:18:01 -0700 Subject: [PATCH 175/233] fip bench script --- test/fip/bench.sh | 71 ++++++++++++++++++----------------------------- 1 file changed, 27 insertions(+), 44 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 084634e61..edd8c2ad7 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -2,7 +2,8 @@ # runparams="100000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" -benchmarks="tmap rbtree ftree msort qsort" +benchmarks="rbtree ftree msort qsort tmap" +graphvariants="fip std std-noreuse stl stl-mi" # note: order matters as it is made relative to the first benches_tmapkk="tmap/tmap-fip.kk tmap/tmap-std.kk" @@ -11,7 +12,7 @@ benches_rbtreekk="rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-s benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" benches_sortkk="sort/msort-fip.kk sort/msort-std.kk sort/qsort-fip.kk sort/qsort-std.kk" benches_fingerkk="finger/ftree-fip.kk finger/ftree-std.kk" -benches_all="$benches_tmapkk $benches_tmapc $benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk" +benches_all="$benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk $benches_tmapkk $benches_tmapc" # get this by running `stack path | grep local-install-root`` in the koka development directory # koka_install_dir="/mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/665c0f3ba306de11186f0f92ea0ca8305283b035f4fa2dfb5c2b12a96689073b/8.10.7" @@ -369,8 +370,9 @@ function avg_all { } -#-------------------------------------- -# graph with xtick each benchmark + +#------------------------------------- +# graph with the x ticks for each runparam function xgraph_variant { # map # $1 $2 $3 $4 $5 $6 $7 $8 $9 @@ -402,7 +404,7 @@ function xgraph_variant { # map > $6 } -function graph_all { +function xgraph_all { local logbench="./log/avg.txt" local texdata="./log/graph.tex" echo "\\pgfplotsset{" > $texdata @@ -440,26 +442,24 @@ function graph_all { } -#------------------------------------- -# graph with the x ticks for each runparam +#-------------------------------------- +# graph with xtick each benchmark -function xgraph_variant { # map + +function graph_variant { # $1= $2= $3= $4= $5= + # # $1 $2 $3 $4 $5 $6 $7 $8 $9 # log entry: kk map trmc 1000 awk ' BEGIN { prefix="'"$1"'" - bench="'"$2"'" - variant="'"$3"'" - varianttexname="'"$4"'" + variant="'"$2"'" + varianttexname="'"$3"'" print "\\pgfplotstableread{" print "x y y-error meta" } - $1==prefix && $2==bench && $3==variant { - if ($1 == "kk" && $3 == "trmc") { - printf( "%i %0.3f %0.3f {\\absnormlabel{%0.2f}}\n", i++, $6, $7, $5 ); - } - else if ($6 == 0.1) { + $1==prefix && $3==variant { + if ($6 == 0.1) { printf( "%i 0.100 0.000 {\\!\\!out of stack}\n", i++); } else { @@ -467,45 +467,28 @@ function xgraph_variant { # map > $6 + ' $4 >> $5 } -function xgraph_all { +function graph_all { local logbench="./log/avg.txt" local texdata="./log/graph.tex" + echo "\\pgfplotsset{" > $texdata echo " xticklabels = {" >> $texdata - #local benchname="" - #for bench in $benches; do - # local bbench=${bench#*\/} # no directory - # benchname=${bbench%\_*} - # break - #done - for runparam in $runparams; do - local lab="$runparam" - if [ "$lab" = "10000" ]; then - lab="10\\nsep 000" - elif [ "$lab" = "100000" ]; then - lab="100\\nsep 000" - elif [ "$lab" = "1000000" ]; then - lab="1\\nsep 000\\nsep 000" - fi - echo " \\strut $lab," >> $texdata - done + for benchmark in $benchmarks; do + echo " \\strut $benchmark," >> $texdata + done echo "}}" >> $texdata echo " " >> $texdata - for bench in $benches; do - local prefix=${bench#*\.} - local base=${bench%\.*} # no extension - local stem=${base##*\/} # no directory - local variant=${stem#*-} + + for variant in $graphvariants; do local varianttexname="${variant//-/}" - local benchname=${stem%%-*} - echo "GRAPH $benchname, $variant" - xgraph_variant $prefix $benchname $variant $varianttexname $logbench $texdata + graph_variant "kk" $variant $varianttexname $logbench $texdata + # graph_variant "cpp" $variant $varianttexname $logbench $texdata done cat $texdata } From d30f6a6ce798a43628dbf18bcb153e8f2e63f552 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 6 May 2023 12:29:23 -0700 Subject: [PATCH 176/233] improve bench graphing --- test/fip/bench.sh | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index edd8c2ad7..3b0b2633b 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -3,7 +3,7 @@ runparams="100000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" benchmarks="rbtree ftree msort qsort tmap" -graphvariants="fip std std-noreuse stl stl-mi" +graphvariants="fip std std-noreuse stl stl-mi std-mi" # note: order matters as it is made relative to the first benches_tmapkk="tmap/tmap-fip.kk tmap/tmap-std.kk" @@ -459,7 +459,10 @@ function graph_variant { # $1= $2= $3= $4= Date: Mon, 8 May 2023 16:13:06 -0700 Subject: [PATCH 177/233] re-add fbip benchmarks --- test/fip/src/finger/ftree-fip.kk | 283 +++++++++++++++++++++++++ test/fip/src/finger/ftree-std.kk | 112 ++++++++++ test/fip/src/msort/msort-fip.kk | 133 ++++++++++++ test/fip/src/msort/msort-std.kk | 58 +++++ test/fip/src/qsort/qsort-fip.kk | 97 +++++++++ test/fip/src/qsort/qsort-std.kk | 40 ++++ test/fip/src/rbtree/rbtree-clrs-full.c | 187 ++++++++++++++++ test/fip/src/rbtree/rbtree-clrs.c | 183 ++++++++++++++++ test/fip/src/rbtree/rbtree-fip-clrs.kk | 91 ++++++++ test/fip/src/rbtree/rbtree-fip-icfp.kk | 77 +++++++ test/fip/src/rbtree/rbtree-fip.kk | 79 +++++++ test/fip/src/rbtree/rbtree-std.kk | 91 ++++++++ test/fip/src/rbtree/rbtree-stl.cpp | 64 ++++++ test/fip/src/tmap/tmap-fip.c | 101 +++++++++ test/fip/src/tmap/tmap-fip.kk | 47 ++++ test/fip/src/tmap/tmap-std.c | 82 +++++++ test/fip/src/tmap/tmap-std.kk | 34 +++ 17 files changed, 1759 insertions(+) create mode 100644 test/fip/src/finger/ftree-fip.kk create mode 100644 test/fip/src/finger/ftree-std.kk create mode 100644 test/fip/src/msort/msort-fip.kk create mode 100644 test/fip/src/msort/msort-std.kk create mode 100644 test/fip/src/qsort/qsort-fip.kk create mode 100644 test/fip/src/qsort/qsort-std.kk create mode 100644 test/fip/src/rbtree/rbtree-clrs-full.c create mode 100644 test/fip/src/rbtree/rbtree-clrs.c create mode 100644 test/fip/src/rbtree/rbtree-fip-clrs.kk create mode 100644 test/fip/src/rbtree/rbtree-fip-icfp.kk create mode 100644 test/fip/src/rbtree/rbtree-fip.kk create mode 100644 test/fip/src/rbtree/rbtree-std.kk create mode 100644 test/fip/src/rbtree/rbtree-stl.cpp create mode 100644 test/fip/src/tmap/tmap-fip.c create mode 100644 test/fip/src/tmap/tmap-fip.kk create mode 100644 test/fip/src/tmap/tmap-std.c create mode 100644 test/fip/src/tmap/tmap-std.kk diff --git a/test/fip/src/finger/ftree-fip.kk b/test/fip/src/finger/ftree-fip.kk new file mode 100644 index 000000000..be025f0a0 --- /dev/null +++ b/test/fip/src/finger/ftree-fip.kk @@ -0,0 +1,283 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +ref type pad + Pad + +type reuse3 + Reuse3(a : pad, b : pad, c : pad) + +type afew + One(a : a, b : pad, c : pad) + Two(a : a, b : a, c : pad) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a, c : pad) + Triple(a : a, b : a, c : a) + +type seq + Empty + Unit(a : a, b : pad, c : pad) + More0(l : a, s : seq>, r : afew) + More(l : tuple, s : seq>, r : afew) + +type buffer + BNil + BCons(next : buffer, b : pad, c : pad) + +value type bseq + BSeq(s : seq, q : buffer) + +// Isomorphic to (,,,) but unboxed +value type tuple4 + Tuple4(fst:a,snd:b,thd:c,field4:d) + +fun bhead(^bs : bseq) : exn a + match bs + BSeq(s, _) -> head(s) + +fun head(^s : seq) : exn a + match s + Unit(x) -> x + More0(x, _, _) -> x + More(Pair(x, _, _), _, _) -> x + More(Triple(x, _, _), _, _) -> x + +fip fun bcons(x : a, u3 : reuse3, bs : bseq) : exn bseq + val BSeq(s, b) = bs + val (s', b') = cons(x, u3, s, b) + BSeq(s', b') + +fip fun cons(x : a, u3 : reuse3, s : seq, b : buffer) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) + More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) + More(Pair(y, z, _), q, u) -> + (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) + More(Triple(y, z, w), q, u) -> + val BCons(b', _, _) = b + val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') + (More(Pair(x, y, Pad), q', u), b'') + +fip fun buncons(bs : bseq) : exn (a, reuse3, bseq) + val BSeq(s, b) = bs + val Tuple4(x, u3, s', b') = uncons(s, b) + (x, u3, BSeq(s', b')) + +fip fun uncons(s : seq, b : buffer) : exn tuple4, buffer> + match s + Unit(x, _, _) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) + More(Triple(x, y, z), q, u) -> + val BCons(b', _, _) = b + Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') + More(Pair(x, y, _), q, u) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) + More0(x, q, u) -> + val (q', b') = more0(q, u, b) + Tuple4(x, Reuse3(Pad,Pad,Pad), q', b') + +fip fun more0(q : seq>, u : afew, b : buffer) : exn (seq, buffer) + match q + Empty -> + match u + One(x, y, z) -> (Unit(x, y, z), b) + Two(y, z, _) -> + val BCons(b', _, _) = b + (More0(y, Empty, One(z, Pad, Pad)), b') + Three(y, z, w) -> + val BCons(b', _, _) = b + (More0(y, Empty, Two(z, w, Pad)), b') + Unit(p, _, _) -> + match p + Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') + More0(p, q1, u1) -> + match p + Pair(x, y) -> + val (q1', b') = more0(q1, u1, b) + (More(Pair(x, y, Pad), q1', u), b') + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') + More(Pair(p, y1), q1, u1) -> + match p + Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') + More(Triple(p, y1, z1), q1, u1) -> + val BCons(b', _, _) = b + match p + Pair(x, y) -> + (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') + Triple(x, y, z) -> + (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') + +fip fun bsnoc(bs : bseq, u3 : reuse3, x : a) : exn bseq + val BSeq(s, b) = bs + val (s', b') = snoc(s, b, u3, x) + BSeq(s', b') + +fip fun snoc(s : seq, b : buffer, u3 : reuse3, x : a) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) + More0(u, q, One(y, _, _)) -> (More0(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More (u, q, One(y, _, _)) -> (More (u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More0(u, q, Two(y, z, _)) -> (More0(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More (u, q, Two(y, z, _)) -> (More (u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More0(u, q, Three(y, z, w)) -> + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More0(u, q', Two(w, x, Pad)), b'') + More(u, q, Three(y, z, w)) -> + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More(u, q', Two(w, x, Pad)), b'') + +// append + +type list3 + Cons3(x : a, xx : list3, c : pad) + Nil3 + +fip fun reverse3(xs : list3) : list3 + reverse-append3( xs, Nil3 ) + +fip fun reverse-acc(acc : list3, ys : list3 ) : list3 + match ys + Cons3(x,xx,pad) -> reverse-acc(Cons3(x,acc,pad),xx) + _ -> acc + +fip fun reverse-append3( xs : list3, tl : list3 ) : list3 + reverse-acc(tl,xs) + +fip fun (++)(xs : list3, ys : list3 ) : list3 + append3(xs, ys) + +fip fun append3(xs : list3, ys : list3 ) : list3 + match xs + Cons3(x,xx,pad) -> Cons3(x,append3(xx,ys),pad) + Nil3 -> ys + +fip fun foldl3(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(z1,z2,Reuse3(Pad,Pad,Pad),x) + foldl3(xx,z1',z2',f) + Nil3 -> (z1,z2) + +// foldl3 specialized to the `flip` function +fip fun foldl3_flipped(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(x,Reuse3(Pad,Pad,Pad),z1,z2) + foldl3_flipped(xx,z1',z2',f) + Nil3 -> (z1,z2) + +fip fun foldr3(xs,z1,z2,^f) + xs.reverse3.foldl3_flipped(z1,z2,f) + +fip fun (++)( xs : buffer, ys : buffer ) : buffer + append-buffers(xs, ys) + +fip fun append-buffers(b1 : buffer, b2 : buffer) : buffer + match b1 + BNil -> b2 + BCons(b', _, _) -> BCons(append-buffers(b', b2), Pad, Pad) + +fip fun afew-to-list(u : afew, b : buffer) : exn (list3, buffer) + match u + One(x) -> (Cons3(x, Nil3, Pad), b) + Two(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Three(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun tuple-to-list(u : tuple, b : buffer) : exn (list3, buffer) + match u + Pair(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Triple(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun to-tuples(xs : list3, b : buffer) : (list3>, buffer) + match xs + Cons3(x, Cons3(y, Nil3)) -> + (Cons3(Pair(x,y,Pad), Nil3, Pad), b) + Cons3(x, Cons3(y, Cons3(z, Cons3(w, Nil3)))) -> + (Cons3(Pair(x,y,Pad), Cons3(Pair(z,w,Pad),Nil3,Pad), Pad), b) + Cons3(x, Cons3(y, Cons3(z, xs))) -> + val (xs', b') = to-tuples(xs, b) + (Cons3(Triple(x,y,z), xs', Pad), BCons(b', Pad, Pad)) + _ -> (Nil3, b) // only if xs == Nil3 + +fip fun append(q1 : bseq, q2 : bseq) : pure bseq + match (q1, q2) + (BSeq(q1, b1), BSeq(q2, b2)) -> + val (q, b) = glue(q1, b1, Nil3, BNil, q2, b2) + BSeq(q, b) + +fip fun glue(q1 : seq, b1 : buffer, xs : list3, bs0 : buffer, q2 : seq, b2 : buffer) : pure (seq, buffer) + match(q1, q2) + (Empty, q2) -> xs.foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Empty) -> xs.foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (Unit(x,_,_), q2) -> (Cons3(x,xs,Pad)).foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Unit(x,_,_)) -> append3(xs,Cons3(x,Nil3,Pad)).foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + (More(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + +// benchmark + +fun iterate(s : bseq, n : int32) : bseq + if n <= 0.int32 then s + else + val (x, u3, s') = buncons(s) + iterate(bsnoc(s', u3, x), n - 1.int32) + +fun build(n : int32, s : bseq) : bseq + if n <= 0.int32 then s else build(n - 1.int32, bsnoc(s, Reuse3(Pad,Pad,Pad), n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, BSeq(Empty, BNil)) + acc + bhead(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/finger/ftree-std.kk b/test/fip/src/finger/ftree-std.kk new file mode 100644 index 000000000..bcfbfd7e8 --- /dev/null +++ b/test/fip/src/finger/ftree-std.kk @@ -0,0 +1,112 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +// Originally "some" which is a reserved keyword in Koka +type afew + One(a : a) + Two(a : a, b : a) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a) + Triple(a : a, b : a, c : a) + +type seq + Empty // Nil is used for the empty list in Koka + Unit(a : a) + More(l : afew, s : seq>, r : afew) + +fun head(s : seq) : a + match s + Unit(x) -> x + More(One(x), _, _) -> x + More(Two(x, _), _, _) -> x + More(Three(x, _, _), _, _) -> x + +fun cons(x : a, s : seq) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(x), Empty, One(y)) + More(One(y), q, u) -> More(Two(x, y), q, u) + More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) + More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) + +fun uncons(s : seq) : (a, seq) + match s + Unit(x) -> (x, Empty) + More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) + More(Two(x, y), q, u) -> (x, More(One(y), q, u)) + More(One(x), q, u) -> (x, more0(q, u)) + +// we inline chop and map1 for better reuse behaviour +fun more0(q : seq>, u : afew) : seq + match q + Empty -> match u + One(y) -> Unit(y) + Two(y, z) -> More(One(y), Empty, One(z)) + Three(y, z, w) -> More(One(y), Empty, Two(z, w)) + Unit(p) -> match p + Pair(x, y) -> More(Two(x, y), Empty, u) + Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) + More(One(p), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) + Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) + More(Two(p, y1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) + More(Three(p, y1, z1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) + +fun snoc(s : seq, x : a) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(y), Empty, One(x)) + More(u, q, One(y)) -> More(u, q, Two(y, x)) + More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) + More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) + +fun to-list(u : afew) : list + match u + One(x) -> [x] + Two(x,y) -> [x,y] + Three(x,y,z) -> [x,y,z] + +fun to-tuples(xs : list) : list> + match xs + Cons(x, Cons(y, Nil)) -> [Pair(x,y)] + Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] + Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) + _ -> [] // only if xs == Nil + +fun append(q1 : seq, q2 : seq) :
seq + glue(q1, Nil, q2) + +fun glue(q1 : seq, xs : list, q2 : seq) :
seq + match(q1, q2) + (Empty, _) -> xs.foldr(q2, cons) + (_, Empty) -> xs.foldl(q1, snoc) + (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) + (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) + +fun iterate(s : seq, n : int32) : seq + if n <= 0.int32 then s + else + val (x, s') = uncons(s) + iterate(snoc(s', x), n - 1.int32) + +fun build(n : int32, s : seq) :
seq + if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, Empty) + acc + head(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/msort/msort-fip.kk b/test/fip/src/msort/msort-fip.kk new file mode 100644 index 000000000..8b0f077b7 --- /dev/null +++ b/test/fip/src/msort/msort-fip.kk @@ -0,0 +1,133 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +type unit2 + Unit2(a : pad, b : pad) + +type pair + Pair(a : a, b : a) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Sublist(c : sublist, z : partition) + Singleton(c : a, z : partition) + End + +fip fun reverse-go(c : sublist, acc : sublist, u : unit2) : sublist + match c + SCons(a, cs) -> reverse-go(cs, SCons(a, acc), u) + STuple(a, b) -> SCons(b, SCons(a, acc)) + +fip fun reverse-sublist(c : sublist) : sublist + match c + SCons(a, SCons(b, c)) -> reverse-go(c, STuple(b, a), Unit2(Pad,Pad)) + SCons(a, STuple(b, c)) -> SCons(c, STuple(b, a)) + STuple(a, b) -> STuple(b, a) + +fip fun sequences(xs : list) : div partition + match(xs) + Cons(a, Cons(b, xs1)) -> if(a > b) + then + val (sublist, bs) = descending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + else + val (sublist, bs) = ascending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + Cons(a, Nil) -> Singleton(a, End) + Nil -> End + +fip fun descending(a : elem, sublist : sublist, bs : list) : (sublist, list) + match(bs) + Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1) + bs -> (sublist, bs) + +fip fun ascending(a : elem, sublist : sublist, bs : list) : (sublist, list) + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1) + bs -> (reverse-sublist(sublist), bs) + +fip fun to-list(c : sublist, u : unit2) : list + match c + SCons(a, cs) -> Cons(a, to-list(cs, u)) + STuple(a, b) -> Cons(a, Cons(b, Nil)) + +fip fun merge-all(xs : partition) :
list + match(xs) + Sublist(x, End) -> to-list(x, Unit2(Pad,Pad)) + Singleton(x, End) -> Cons(x, Nil) + xs -> merge-all(merge-pairs(xs)) + +fip fun merge-pairs(xs : partition) :
partition + match(xs) + Sublist(a, Sublist(b, xs1)) -> Sublist(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Sublist(a, Singleton(b, xs1)) -> Sublist(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Sublist(b, xs1)) -> Sublist(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Singleton(b, xs1)) -> + Sublist(if a <= b then STuple(a, b) else STuple(b, a), merge-pairs(xs1)) + xs -> xs + +fip fun merge(c1 : sublist, c2 : sublist, u : unit2) :
sublist + match c1 + SCons(a, cs1) -> match c2 + SCons(b, cs2) -> + if a <= b then SCons(a, merge(cs1, SCons(b, cs2), u)) + else SCons(b, merge(SCons(a, cs1), cs2, u)) + STuple(b, c) -> + if a <= b then SCons(a, merge(cs1, STuple(b, c), u)) + else SCons(b, merge-last-left(SCons(a, cs1), c, u)) + STuple(a, b) -> match c2 + SCons(c, cs2) -> + if a <= c then SCons(a, merge-last-right(b, SCons(c, cs2), u)) + else SCons(c, merge(STuple(a, b), cs2, u)) + STuple(c, d) -> + if a <= c then SCons(a, merge-right(b, Pair(c, d), u)) + else SCons(c, merge-left(Pair(a, b), d, u)) + +fip fun merge-last-right(a : elem, c2 : sublist, u : unit2) : sublist + match c2 + SCons(b, cs2) | a <= b -> SCons(a, SCons(b, cs2)) + | _ -> SCons(b, merge-last-right(a, cs2, u)) + STuple(b, c) -> merge-right(a, Pair(b, c), u) + +fip fun merge-last-left(c2 : sublist, d : elem, u : unit2) : sublist + match c2 + SCons(a, cs2) | a <= d -> SCons(a, merge-last-left(cs2, d, u)) + | _ -> SCons(d, SCons(a, cs2)) + STuple(a, b) -> merge-left(Pair(a, b), d, u) + +fip fun merge-right(a : elem, p : pair, u : unit2) : sublist + match p + Pair(b, c) | a <= b -> SCons(a, STuple(b, c)) + | _ -> SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) + +fip fun merge-left(p : pair, d : elem, u : unit2) : sublist + match p + Pair(a, b) | a <= d -> SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) + | _ -> SCons(d, STuple(a, b)) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/msort/msort-std.kk b/test/fip/src/msort/msort-std.kk new file mode 100644 index 000000000..9fcb70ca7 --- /dev/null +++ b/test/fip/src/msort/msort-std.kk @@ -0,0 +1,58 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun sequences(xs : list) :
list> + match(xs) + Cons(a, Cons(b, xs1)) -> + if(a > b) then descending(b, Cons(a, Nil), xs1) + else ascending(b, Cons(a, Nil), xs1) + _ -> Cons(xs, Nil) + +fun descending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) + _ -> Cons(Cons(a, chain), sequences(bs)) + +fun ascending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) + _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) + +fun merge-all(xs : list>) :
list + match xs + Cons(x, Nil) -> x + _ -> merge-all(merge-pairs(xs)) + +fun merge-pairs(xs : list>) :
list> + match xs + Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) + _ -> xs + +fun merge(xs : list, ys : list) :
list + match(xs, ys) + (Cons(x, xx), Cons(y, yy)) -> + if(x > y) then Cons(y, merge(xs, yy)) + else Cons(x, merge(xx, ys)) + (Cons(_, _), Nil) -> xs + (_, _) -> ys + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/qsort/qsort-fip.kk b/test/fip/src/qsort/qsort-fip.kk new file mode 100644 index 000000000..d7f94c3c3 --- /dev/null +++ b/test/fip/src/qsort/qsort-fip.kk @@ -0,0 +1,97 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +ref type unit2 + Unit2(a : pad, b : pad) + +type maybe2 + Nothing2 + Just2(a : a, b : pad) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Sublist(c : sublist, bdl : partition) + Singleton(c : a, bdl : partition) + End + +fip fun quicksort(xs : list) : div list + quicksort-go(xs, End) + +fip fun quicksort-go(xs : list, b : partition) : div list + match xs + Cons(p, xx) -> + val (lo, hi) = split-list(p, xx, Done, b, Unit2(Pad,Pad)) + quicksort-go(lo, hi) + Nil -> quicksort-app(b) + +fip fun quicksort-app(bdl : partition) : div list + match bdl + Singleton(p, b) -> Cons(p,quicksort-app(b)) + Sublist(xs, bdl') -> match xs + SCons(p, xx) -> + val (lo, hi) = split-sublist(p, xx, Done, bdl', Unit2(Pad,Pad), Unit2(Pad,Pad)) + quicksort-go(lo, hi) + STuple(a, b) | a <= b -> Cons(a, Cons(b, quicksort-app(bdl'))) + | _ -> Cons(b, Cons(a, quicksort-app(bdl'))) + End -> Nil + +type accum + MkLo(x : a, k : accum) + MkHi(x : a, k : accum) + Done + +fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) + match xs + Cons(x, xx) | x < p -> split-list(p, xx, MkLo(x, k), b, u) + | _ -> split-list(p, xx, MkHi(x, k), b, u) + Nil -> + val (lo, hi) = split-app1(k, Nil, Nothing2, b) + (lo, Singleton(p, hi)) + +fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) + match xs + SCons(x, xx) | x < p -> split-sublist(p, xx, MkLo(x, k), b, u, u1) + | _ -> split-sublist(p, xx, MkHi(x, k), b, u, u1) + STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) + +fip fun split-app1(k : accum, lo : list, hi : maybe2, b : partition) :
(list, partition) + match k + MkLo(x, k) -> split-app1(k, Cons(x, lo), hi, b) + MkHi(x, k) -> match hi + Nothing2 -> split-app1(k, lo, Just2(x, Pad), b) + Just2(y, _) -> split-app2(k, lo, STuple(y,x), b, Unit2(Pad,Pad)) + Done -> match hi + Just2(x, _) -> (lo, Singleton(x, b)) + Nothing2 -> (lo, b) + +fip fun split-app2(k : accum, lo : list, hi : sublist, b : partition, u : unit2) : (list, partition) + match k + MkLo(x, k) -> split-app2(k, Cons(x,lo), hi, b, u) + MkHi(x, k) -> split-app2(k, lo, SCons(x,hi), b, u) + Done -> (lo, Sublist(hi, b)) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/qsort/qsort-std.kk b/test/fip/src/qsort/qsort-std.kk new file mode 100644 index 000000000..9c62aaf35 --- /dev/null +++ b/test/fip/src/qsort/qsort-std.kk @@ -0,0 +1,40 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun quicksort(xs : list, res : list) : list + match(xs) + Cons(x, xx) -> + val (lo, hi) = partition(x, xx) + quicksort(lo, Cons(x, quicksort(hi, res))) + Nil -> res + +fun partition(^x : elem, ys : list) + match(ys) + Cons(y, yy) -> + if(y < x) then + val (lo, hi) = partition(x, yy) + (Cons(y, lo), hi) + else + val (lo, hi) = partition(x, yy) + (lo, Cons(y, hi)) + Nil -> (Nil, Nil) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs, Nil) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-clrs-full.c b/test/fip/src/rbtree/rbtree-clrs-full.c new file mode 100644 index 000000000..29cfe80b1 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-clrs-full.c @@ -0,0 +1,187 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein +// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + while(z->parent != T->nil) { + z = z->parent; + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-clrs.c b/test/fip/src/rbtree/rbtree-clrs.c new file mode 100644 index 000000000..1a31ca7dc --- /dev/null +++ b/test/fip/src/rbtree/rbtree-clrs.c @@ -0,0 +1,183 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-fip-clrs.kk b/test/fip/src/rbtree/rbtree-fip-clrs.kk new file mode 100644 index 000000000..370801adc --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip-clrs.kk @@ -0,0 +1,91 @@ +import std/num/int32 +import std/os/env + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf + +fip fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree + match t + Node(c, l, kx, vx, r) + -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) + elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) + else balance(z, Node(c, l, key, v, r)) + Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) + +fip fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + t -> t + +fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : tree ) : exn tree + match z + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) + else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) + Done -> Node(Black, l1, k1, v1, t) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) + else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) + Done -> Node(Black, t, k1, v1, r1) + z -> rebuild(z, t) + + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-fip-icfp.kk b/test/fip/src/rbtree/rbtree-fip-icfp.kk new file mode 100644 index 000000000..9ae787768 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip-icfp.kk @@ -0,0 +1,77 @@ +import std/num/int32 +import std/os/env + +ref type pad + Pad + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : balance-node ) : tree + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Leaf, k, v, Leaf, Balance(Red,Leaf,0.int32,True,Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree-fip.kk b/test/fip/src/rbtree/rbtree-fip.kk new file mode 100644 index 000000000..ad21e327f --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip.kk @@ -0,0 +1,79 @@ +import std/num/int32 +import std/os/env + +type any + Any + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : balance-node ) : tree + match t + Balance(_,l,k,v,r) -> + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Balance(Black, Leaf, k, v, Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree-std.kk b/test/fip/src/rbtree/rbtree-std.kk new file mode 100644 index 000000000..f16c30227 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-std.kk @@ -0,0 +1,91 @@ +// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean +import std/num/int32 +import std/os/env + +type color + Red + Black + + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + + +fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + + +fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree + match l + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) + Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) + -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) + Node(_, lx, kx, vx, rx) + -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) + Leaf -> Leaf + + +fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree + match r + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) + Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) + Node(_, lx, kx, vx, rx) + -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) + Leaf -> Leaf + + +fun ins(t : tree, k : int32, v : bool) : tree + match t + Node(Red, l, kx, vx, r) + -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) + elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) + else Node(Red, l, k, v, r) + Node(Black, l, kx, vx, r) + -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) + else Node(Black, ins(l, k, v), kx, vx, r)) + elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) + else Node(Black, l, kx, vx, ins(r, k, v))) + else Node(Black, l, k, v, r) + Leaf -> Node(Red, Leaf, k, v, Leaf) + + +fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + _ -> t + + +fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v).set-black + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : div tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : div tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-stl.cpp b/test/fip/src/rbtree/rbtree-stl.cpp new file mode 100644 index 000000000..fbc9b5927 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-stl.cpp @@ -0,0 +1,64 @@ +// Using standard STL to test the red-black tree in C++ +// In glibc++ this uses +// With the LLVM libc++ this uses +// In glibc this uses eventually: +// (Highly optimized in-place red-black tree using the low pointer bit to encode color information.) + +#include +#include +#include +using std::for_each; + +typedef int32_t nat; + +struct nat_lt_fn { + bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; } +}; + +typedef std::map map; + +map mk_map(unsigned n) { + map m; + while (n > 0) { + --n; + m.insert(std::make_pair(nat(n), n%10 == 0)); + } + return m; +} + +nat fold(map const & m) { + nat r(0); + for_each(m.begin(), m.end(), [&](std::pair const & p) { if (p.second) r = r + nat(1); }); + return r; +} + +/* +int main(int argc, char ** argv) { + unsigned n = 4200000; + if (argc == 2) { + n = atoi(argv[1]); + } + map m = mk_map(n); + std::cout << fold(m) << "\n"; + return 0; +} +*/ + +void test(int n) { + int iter = 10000000 / (n <= 0 ? 1 : n); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + map m = mk_map(n); + acc += fold(m); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-fip.c b/test/fip/src/tmap/tmap-fip.c new file mode 100644 index 000000000..b30e2754d --- /dev/null +++ b/test/fip/src/tmap/tmap-fip.c @@ -0,0 +1,101 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t header; + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->header = 0; + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { + struct node* acc = NULL; + + acc: + while(root != NULL) { + struct node* acc_ = create_node(root->data); + acc_->left = acc; + acc_->right = root->right; + root = root->left; + acc = acc_; + } + + app: + if(acc == NULL) return root; + if(acc->header == 0) { + struct node* right = acc->right; + acc->header = 1; + acc->data = f(acc->data); + acc->right = acc->left; + acc->left = root; + root = right; + goto acc; + } else { // acc->header == 1 + struct node* acc_ = acc->right; + acc->right = root; + root = acc; + acc = acc_; + goto app; + } +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + x += sum_tree(tmap(xs, increment)); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-fip.kk b/test/fip/src/tmap/tmap-fip.kk new file mode 100644 index 000000000..861765715 --- /dev/null +++ b/test/fip/src/tmap/tmap-fip.kk @@ -0,0 +1,47 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32_go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) + +fun tsum32(t0 : tree) + tsum32_go(t0, 0.int32) + +type accum + Hole + BinR(k : accum, x : a, r : tree) + BinL(l : tree, x : b, k : accum) + +fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree + match t + Leaf -> tmap-app( k, f, Leaf ) + Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) + +fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree + match k0 + BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) + BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) + Hole -> t + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 + println("total: " ++ x.show) + + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/tmap/tmap-std.c b/test/fip/src/tmap/tmap-std.c new file mode 100644 index 000000000..520951f78 --- /dev/null +++ b/test/fip/src/tmap/tmap-std.c @@ -0,0 +1,82 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { + while(root != NULL) { + struct node* root_ = create_node(root->data); + tmap(root->left, f, &root_->left); + root_->data = f(root_->data); + *dest = root_; + dest = &root_->right; + root = root->right; + } + *dest = NULL; +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + struct node* ys; + tmap(xs, increment, &ys); + x += sum_tree(ys); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-std.kk b/test/fip/src/tmap/tmap-std.kk new file mode 100644 index 000000000..e41f79750 --- /dev/null +++ b/test/fip/src/tmap/tmap-std.kk @@ -0,0 +1,34 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun tmap-std( xs : tree, f : a -> e b ) : e tree + match xs + Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) + Leaf -> Leaf + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-std(fn(x) x.inc).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) From 66959f25434ee58edb341b4bf23dc6c6c62d5e37 Mon Sep 17 00:00:00 2001 From: Daan Date: Mon, 8 May 2023 16:29:17 -0700 Subject: [PATCH 178/233] add c++17 flag in benchmark fip --- test/fip/bench.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 3b0b2633b..73ee190ce 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -230,7 +230,7 @@ function build_cpp { # local srcname="$1" local base=${1%.*} local stem=${base##*/} - local options="-O3 -o $cppoutdir/$stem $cppopts" + local options="--std=c++17 -O3 -o $cppoutdir/$stem $cppopts" if [[ $(uname -m) == 'arm64' ]]; then options="$options -mcpu=apple-m1" else From 71b3d682a778eb012324692aba6503c008ff282f Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Wed, 10 May 2023 16:53:01 -0700 Subject: [PATCH 179/233] Refactor and clean up FBIP analysis --- src/Core/CheckFBIP.hs | 219 +++++++++++++++++++++--------------------- 1 file changed, 109 insertions(+), 110 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 943788966..3360b6943 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -17,7 +17,7 @@ module Core.CheckFBIP( checkFBIP import qualified Lib.Trace import Control.Monad import Control.Applicative -import Data.List( partition, intersperse, foldl1', foldl', isSuffixOf, uncons ) +import Data.List( partition, intersperse, foldl1', foldl', isSuffixOf, uncons, sortBy ) import qualified Data.Set as S import qualified Data.Map as M @@ -46,7 +46,9 @@ import Core.Borrowed import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) import Backend.C.ParcReuse (getFixedDataAllocSize) import Backend.C.Parc (getDataDef') -import Data.List (tails) +import Data.List (tails, sortOn) +import Data.Ratio +import Data.Ord (comparing, Down (Down)) trace s x = Lib.Trace.trace s @@ -80,28 +82,27 @@ chkTopLevelDef defGroupNames def case defSort def of -- only check fip and fbip annotated functions DefFun borrows fip | not (isNoFip fip) -> - do out <- withFip fip $ - extractOutput $ - withInput (\_ -> Input S.empty (capFromFip fip) defGroupNames True) $ - chkTopLevelExpr borrows fip (defExpr def) - checkOutputEmpty out + withFip fip $ + do out <- extractOutput $ + withInput (\_ -> Input S.empty defGroupNames True) $ + chkTopLevelExpr borrows (defExpr def) + checkOutputEmpty out _ -> return () - -- | Lambdas at the top-level are part of the signature and not allocations. -chkTopLevelExpr :: [ParamInfo] -> Fip -> Expr -> Chk () -chkTopLevelExpr borrows fip (Lam pars eff body) -- todo: track fip to adjust warnings +chkTopLevelExpr :: [ParamInfo] -> Expr -> Chk () +chkTopLevelExpr borrows (Lam pars eff body) = do chkEffect eff - let bpars = map snd $ filter ((==Borrow) . fst) $ zipDefault Own borrows pars - let opars = map snd $ filter ((==Own) . fst) $ zipDefault Own borrows pars + let bpars = map snd $ filter ((==Borrow) . fst) $ zipParamInfo borrows pars + let opars = map snd $ filter ((==Own) . fst) $ zipParamInfo borrows pars withBorrowed (S.fromList $ map getName bpars) $ do out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out opars -chkTopLevelExpr borrows fip (TypeLam _ body) - = chkTopLevelExpr borrows fip body -chkTopLevelExpr borrows fip (TypeApp body _) - = chkTopLevelExpr borrows fip body -chkTopLevelExpr borrows fip expr +chkTopLevelExpr borrows (TypeLam _ body) + = chkTopLevelExpr borrows body +chkTopLevelExpr borrows (TypeApp body _) + = chkTopLevelExpr borrows body +chkTopLevelExpr borrows expr = chkExpr expr chkExpr :: Expr -> Chk () @@ -111,7 +112,7 @@ chkExpr expr TypeApp body _ -> chkExpr body Lam pars eff body -> do chkEffect eff - requireCapability HasAlloc $ \ppenv -> Just $ + requireCapability mayAlloc $ \ppenv -> Just $ text "Lambdas are always allocated." out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out pars @@ -127,7 +128,7 @@ chkExpr expr withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ withTailMod [Let dgs body] $ chkExpr $ defExpr def Let _ _ - -> unhandled $ text "FIP check can not handle recursive let bindings." + -> emitWarning $ text "FIP check can not handle nested function bindings." Case scrutinees branches -> chkBranches scrutinees branches @@ -144,14 +145,9 @@ chkBranches scrutinees branches = do whichBorrowed <- mapM isBorrowedScrutinee scrutinees let branches' = filter (not . isPatternMatchError) branches outs <- mapM (extractOutput . chkBranch whichBorrowed) branches' - gamma2 <- joinContexts (map branchPatterns branches') outs - writeOutput gamma2 - withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ - withTailModProduct branches' $ -- also filter out pattern match errors - mapM_ chkScrutinee scrutinees - where - fromVar (Var tname _) = Just tname - fromVar _ = Nothing + writeOutput =<< joinContexts (map branchPatterns branches') outs + withTailModProduct branches' $ -- also filter out pattern match errors + mapM_ chkScrutinee scrutinees isBorrowedScrutinee :: Expr -> Chk ParamInfo isBorrowedScrutinee expr@(Var tname info) @@ -167,10 +163,10 @@ chkScrutinee expr = chkExpr expr chkBranch :: [ParamInfo] -> Branch -> Chk () chkBranch whichBorrowed (Branch pats guards) - = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zipDefault Own whichBorrowed pats + = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zipParamInfo whichBorrowed pats outs <- withBorrowed (S.map getName $ bv $ map snd borPats) $ mapM (extractOutput . chkGuard) guards - out <- joinContexts [] outs + out <- joinContexts (repeat pats) outs writeOutput =<< foldM (flip bindPattern) out (map snd ownPats) chkGuard :: Guard -> Chk () @@ -211,11 +207,11 @@ chkApp (Con cname repr) args -- try reuse chkAllocation cname repr chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) - withNonTail $ mapM_ chkArg $ zipDefault Own bs args + withNonTail $ mapM_ chkArg $ zipParamInfo bs args chkFunCallable (getName tname) =<< getFip input <- getInput unless (isTailContext input || getName tname `notElem` defGroupNames input) $ - requireCapability HasStack $ \ppenv -> Just $ + requireCapability mayRecurse $ \ppenv -> Just $ cat [text "Non-tail call to (mutually) recursive function: ", ppName ppenv (getName tname)] chkApp fn args -- local function = do withNonTail $ mapM_ chkExpr args @@ -223,7 +219,7 @@ chkApp fn args -- local function Var tname _ -> isBorrowed tname _ -> pure False unless isBapp $ do - requireCapability HasDealloc $ \ppenv -> Just $ + requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Owned calls to functions require deallocation: ", prettyExpr ppenv fn ] chkExpr fn @@ -237,7 +233,7 @@ chkArg (Borrow, expr) -> chkArg (Borrow, fn) -- disregard .open calls (Var tname info) -> markBorrowed tname info _ -> do chkExpr expr - requireCapability HasDealloc $ \ppenv -> Just $ + requireCapability mayDealloc $ \ppenv -> Just $ text $ "Passing owned expressions as borrowed requires deallocation: " ++ show expr chkLit :: Lit -> Chk () @@ -246,29 +242,30 @@ chkLit lit LitInt _ -> pure () -- we do not care about allocating big integers LitFloat _ -> pure () LitChar _ -> pure () - LitString _ -> requireCapability HasAlloc $ \ppenv -> Just $ + LitString _ -> requireCapability mayAlloc $ \ppenv -> Just $ text "Inline string literals are allocated. Consider lifting to toplevel to avoid this." chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - unhandled $ text "FIP analysis detected that a top-level function was wrapped." + emitWarning $ text "FIP analysis detected that a top-level function was wrapped." chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () chkAllocation cname repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) - = requireCapability HasAlloc $ \ppenv -> Just $ + = requireCapability mayAlloc $ \ppenv -> Just $ cat [text "Types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] chkAllocation cname crepr - = do size <- getConstructorAllocSize crepr + = do size <- getConstructorAllocSize crepr + -- chkTrace $ "Allocation " ++ show cname ++ "/" ++ show size getAllocation cname size -- Only total/empty effects or divergence chkEffect :: Tau -> Chk () chkEffect tp = if isFBIPExtend tp then pure () else - unhandled $ text "Algebraic effects other than are not FIP/FBIP." + emitWarning $ text "Algebraic effects other than are not FIP/FBIP." where isFBIPExtend tp = case extractEffectExtend tp of (taus, tau) -> all isFBIP taus @@ -291,29 +288,19 @@ data Env = Env{ currentDef :: [Def], fip :: Fip } -data Capability - = HasAlloc -- may allocate and dup - | HasDealloc -- may use drop and free - | HasStack -- may use non-tail recursion - deriving (Eq, Ord, Bounded, Enum) - -capFromFip :: Fip -> [Capability] -capFromFip fip - = case fip of - Fip n -> [] - Fbip n isTail -> [HasDealloc] ++ (if isTail then [] else [HasStack]) - NoFip isTail -> [HasDealloc,HasAlloc] ++ (if isTail then [] else [HasStack]) - data Input = Input{ delta :: S.Set Name, - capabilities :: [Capability], defGroupNames :: [Name], isTailContext :: Bool } data Output = Output{ gammaNm :: M.Map TName Int, - gammaDia :: M.Map Int [TName] } + -- ^ matches variables to their number of uses + gammaDia :: M.Map Int [(Ratio Int, [TName])] } + -- ^ matches token size to allocations with a "probability" + -- sorted in descending order of probability instance Semigroup Output where - Output s1 m1 <> Output s2 m2 = Output (M.unionWith (+) s1 s2) (M.unionWith (++) m1 m2) + Output s1 m1 <> Output s2 m2 = + Output (M.unionWith (+) s1 s2) (M.unionWith (\x y -> sortOn (Down . fst) (x ++ y)) m1 m2) instance Monoid Output where mempty = Output M.empty M.empty @@ -331,14 +318,14 @@ prettyCon ppenv tname sz prettyGammaDia :: Pretty.Env -> Output -> Doc prettyGammaDia ppenv (Output nm dia) = tupled $ concatMap - (\(sz, cs) -> map (\c -> prettyCon ppenv c sz) cs) + (\(sz, cs) -> map (\(_, c:_) -> prettyCon ppenv c sz) cs) (M.toList dia) data Result a = Ok a Output [Doc] runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[Doc]) runChk penv u platform newtypes borrowed gamma (Chk c) - = case c (Env [] penv platform newtypes borrowed gamma noFip) (Input S.empty [] [] True) of + = case c (Env [] penv platform newtypes borrowed gamma noFip) (Input S.empty [] True) of Ok x _out docs -> (x,docs) instance Functor Chk where @@ -383,6 +370,37 @@ withFip f chk getFip :: Chk Fip getFip = fip <$> getEnv +mayRecurse :: Chk Bool +mayRecurse + = do fip <- getFip + pure $ case fip of + Fip n -> False + Fbip n isTail -> not isTail + NoFip isTail -> not isTail + +mayDealloc :: Chk Bool +mayDealloc + = do fip <- getFip + pure $ case fip of + Fip n -> False + _ -> True + +data AllocPermission + = Unlimited + | Limited FipAlloc + deriving (Eq, Ord) + +getAlloc :: Chk AllocPermission +getAlloc + = do fip <- getFip + pure $ case fip of + Fip n -> Limited n + Fbip n _ -> Limited n + NoFip _ -> Unlimited + +mayAlloc :: Chk Bool +mayAlloc = (==Unlimited) <$> getAlloc + isCallableFrom :: Fip -> Fip -> Bool isCallableFrom (Fip _) _ = True isCallableFrom (Fbip _ _) (Fbip _ _) = True @@ -406,46 +424,23 @@ chkFunCallable fn fip [] -> emitWarning $ text $ "FIP analysis couldn't find FIP information for function: " ++ show fn infos -> emitWarning $ text $ "FIP analysis found ambiguous FIP information for function: " ++ show fn ++ "\n" ++ show infos --- look up fip annotation; return noFip if not found -lookupFip :: Name -> Chk Fip -lookupFip name - = do env <- getEnv - case filter isInfoFun (gammaLookupQ name (gamma env)) of - [fun] -> return (infoFip fun) - _ -> return noFip - - -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output extractOutput (Chk f) = Chk (\env st -> case f env st of Ok () out doc -> Ok out mempty doc) -useCapabilities :: [Capability] -> Chk a -> Chk a -useCapabilities cs - = withInput (\st -> st {capabilities = cs}) - -hasCapability :: Capability -> Chk Bool -hasCapability c - = do st <- getInput - pure $ c `elem` capabilities st - -- | Perform a test if the capability is not present -- and emit a warning if the test is unsuccessful. -requireCapability :: Capability -> (Pretty.Env -> Maybe Doc) -> Chk () -requireCapability cap test - = do hasCap <- hasCapability cap +requireCapability :: Chk Bool -> (Pretty.Env -> Maybe Doc) -> Chk () +requireCapability mayUseCap test + = do hasCap <- mayUseCap unless hasCap $ do env <- getEnv case test (prettyEnv env) of Just warning -> emitWarning warning Nothing -> pure () -unhandled :: Doc -> Chk () -unhandled doc - = do hasAll <- and <$> mapM hasCapability (enumFromTo minBound maxBound) - unless hasAll $ emitWarning doc - withNonTail :: Chk a -> Chk a withNonTail = withInput (\st -> st { isTailContext = False }) @@ -500,7 +495,7 @@ markSeen tname info | infoIsRefCounted info -- is locally defined? = do b <- isBorrowed tname isHeapValue <- needsDupDrop (tnameType tname) when isHeapValue $ if b - then requireCapability HasAlloc $ \ppenv -> Just $ + then requireCapability mayAlloc $ \ppenv -> Just $ cat [text "Borrowed value used as owned (can cause allocations later): ", ppName ppenv (getName tname)] else writeOutput (Output (M.singleton tname 1) M.empty) markSeen tname info = chkWrap tname info -- wrap rule @@ -511,22 +506,24 @@ markBorrowed nm info unless b $ do markSeen nm info when (infoIsRefCounted info) $ - requireCapability HasDealloc $ \ppenv -> Just $ + requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] getAllocation :: TName -> Int -> Chk () getAllocation nm 0 = pure () getAllocation nm size - = writeOutput (Output mempty (M.singleton size [nm])) + = writeOutput (Output mempty (M.singleton size [(1 % 1, [nm])])) provideToken :: TName -> Int -> Output -> Chk Output provideToken _ 0 out = pure out provideToken debugName size out - = do requireCapability HasDealloc $ \ppenv -> + = do requireCapability mayDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in - if null fittingAllocs then Just $ - cat [text "Unused reuse token provided by ", prettyCon ppenv debugName size] - else Nothing + case fittingAllocs of + [] -> Just $ cat [text "Unused reuse token provided by ", prettyCon ppenv debugName size] + ((r, _):_) | r /= 1%1 -> + Just $ cat [text "Not all branches use reuse token provided by ", prettyCon ppenv debugName size] + _ -> Nothing pure $ out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } joinContexts :: [[Pattern]] -> [Output] -> Chk Output @@ -534,23 +531,21 @@ joinContexts _ [] = pure mempty joinContexts pats cs = do let unionNm = foldl1' (M.unionWith max) (map gammaNm cs) (noDealloc, cs') <- fmap unzip $ forM cs $ \c -> do - let nm = M.difference unionNm (gammaNm c) - (allReusable, c') <- foldM tryReuse (True, c) (map fst $ M.toList nm) + let unused = M.difference unionNm (gammaNm c) + (allReusable, c') <- foldM tryReuse (True, c) (map fst $ M.toList unused) pure (allReusable, c') unless (and noDealloc) $ do - requireCapability HasDealloc $ \ppenv -> Just $ + requireCapability mayDealloc $ \ppenv -> Just $ vcat $ text "Not all branches use the same variables:" : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs - let unionDia = foldl1' (M.unionWith chooseLonger) (map gammaDia cs') - requireCapability HasDealloc $ \ppenv -> - let noDealloc = all (M.null . M.filter (not . null) . M.differenceWith lengthDifferent unionDia . gammaDia) cs' - in if noDealloc then Nothing else Just $ - vcat $ text "Not all branches use the same reuse tokens:" - : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaDia ppenv out]) pats cs' + let unionDia = foldl1' (M.unionWith zipTokens) $ map (M.map (adjustProb (length cs')) . gammaDia) cs' pure (Output unionNm unionDia) where - chooseLonger a b = if length a >= length b then a else b - lengthDifferent a b = if length a /= length b then Just b else Nothing + adjustProb n xs = map (\(p, x) -> (p / (n%1), x) ) xs + + zipTokens ((px, x):xs) ((py, y):ys) = (px + py, x ++ y) : zipTokens xs ys + zipTokens xs [] = xs + zipTokens [] ys = ys tryReuse (allReusable, out) tname = do mOut <- tryDropReuse tname out @@ -587,13 +582,13 @@ bindName nm msize out (Nothing, Nothing) -> do isHeapValue <- needsDupDrop (tnameType nm) when isHeapValue $ - requireCapability HasDealloc $ \ppenv -> Just $ + requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Variable unused: ", ppName ppenv (getName nm)] pure out Just n -> do isHeapVal <- needsDupDrop (tnameType nm) when (n > 1 && isHeapVal) $ - requireCapability HasAlloc $ \ppenv -> Just $ + requireCapability mayAlloc $ \ppenv -> Just $ cat [text "Variable used multiple times: ", ppName ppenv (getName nm)] pure out pure (out { gammaNm = M.delete nm (gammaNm out) }) @@ -605,15 +600,19 @@ checkOutputEmpty out Just ((nm, _), _) -> emitWarning $ text $ "FIP analysis failed as it didn't bind a name: " ++ show nm case M.maxViewWithKey $ gammaDia out of - Just ((sz, c:_), _) | sz > 0 - -> requireCapability HasAlloc $ \ppenv -> Just $ - cat [text "Allocated constructor without reuse token: ", prettyCon ppenv c sz] + Just ((sz, (_, c:cs):_), _) | sz > 0 + -> do permission <- getAlloc + case permission of + Limited (AllocAtMost n) + -> do unless (length (c:cs) <= n) $ do + env <- getEnv + emitWarning $ cat [text "Allocated constructor without reuse token: ", prettyCon (prettyEnv env) c sz] + Limited AllocFinitely -> pure () + Unlimited -> pure () _ -> pure () -zipDefault :: a -> [a] -> [b] -> [(a, b)] -zipDefault x [] (b:bs) = (x, b) : zipDefault x [] bs -zipDefault x (a:as) (b:bs) = (a, b) : zipDefault x as bs -zipDefault x _ [] = [] +zipParamInfo :: [ParamInfo] -> [b] -> [(ParamInfo, b)] +zipParamInfo xs = zip (xs ++ repeat Own) -- value types with reference fields still need a drop needsDupDrop :: Type -> Chk Bool @@ -639,7 +638,7 @@ getPlatform = platform <$> getEnv -- track the current definition for nicer error messages withCurrentDef :: Def -> Chk a -> Chk a withCurrentDef def action - = -- trace ("chking: " ++ show (defName def)) $ + = -- trace ("checking: " ++ show (defName def)) $ withEnv (\env -> env{currentDef = def:currentDef env}) $ action From 902fa1d92cba67fe099f0c1d8708533b52501222 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Thu, 11 May 2023 17:26:27 -0700 Subject: [PATCH 180/233] Improve FIP(n) propagation and report allocation in a loop --- src/Common/Syntax.hs | 34 ++++-- src/Core/CheckFBIP.hs | 241 +++++++++++++++++++++++++----------------- 2 files changed, 169 insertions(+), 106 deletions(-) diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 0756a93f5..4c3fae317 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -338,8 +338,28 @@ data Fip = Fip { fipAlloc_ :: FipAlloc } | NoFip { fipTail :: Bool } deriving (Eq,Ord) -data FipAlloc = AllocAtMost Int | AllocFinitely - deriving (Eq,Ord) +data FipAlloc = AllocAtMost Int | AllocFinitely | AllocUnlimited + deriving (Eq) + +instance Ord FipAlloc where + compare a1 a2 + = case (a1, a2) of + (AllocAtMost n, AllocAtMost m) -> compare n m + (_ , AllocAtMost _) -> GT + + (AllocAtMost n, AllocFinitely) -> LT + (AllocFinitely, AllocFinitely) -> EQ + (AllocUnlimited, AllocFinitely) -> GT + + (AllocUnlimited, AllocUnlimited) -> EQ + (_ , AllocUnlimited) -> LT + +instance Semigroup FipAlloc where + AllocAtMost n <> AllocAtMost m = AllocAtMost (n + m) + _ <> _ = AllocFinitely + +instance Monoid FipAlloc where + mempty = AllocAtMost 0 noFip :: Fip noFip = NoFip False @@ -357,10 +377,9 @@ fipIsTail fip fipAlloc :: Fip -> FipAlloc fipAlloc fip = case fip of - Fip n -> n - Fbip n _ -> n - NoFip _ -> AllocAtMost (-1) - + Fip n -> n + Fbip n _ -> n + NoFip _ -> AllocUnlimited instance Show Fip where show fip = case fip of @@ -370,7 +389,8 @@ instance Show Fip where where showN (AllocAtMost 0) = " " showN (AllocAtMost n) = "(" ++ show n ++ ") " - showN AllocFinitely = "(n) " + showN AllocFinitely = "(n) " + showN AllocUnlimited = "" showTail True = "tail " showTail _ = " " diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 3360b6943..07a40c378 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -49,6 +49,10 @@ import Backend.C.Parc (getDataDef') import Data.List (tails, sortOn) import Data.Ratio import Data.Ord (comparing, Down (Down)) +import Control.Monad.Reader +import Control.Monad.Writer +import Common.Id +import Lib.Printer (Printer(write)) trace s x = Lib.Trace.trace s @@ -81,7 +85,7 @@ chkTopLevelDef defGroupNames def = withCurrentDef def $ do case defSort def of -- only check fip and fbip annotated functions - DefFun borrows fip | not (isNoFip fip) -> + DefFun borrows fip | not (isNoFip fip) -> withFip fip $ do out <- extractOutput $ withInput (\_ -> Input S.empty defGroupNames True) $ @@ -185,10 +189,10 @@ isPatternMatchError _ = False bindPattern :: Pattern -> Output -> Chk Output bindPattern (PatCon cname pats crepr _ _ _ _ _) out - = do size <- getConstructorAllocSize crepr + = do size <- getConstructorAllocSize crepr provideToken cname size =<< foldM (flip bindPattern) out pats bindPattern (PatVar tname (PatCon cname pats crepr _ _ _ _ _)) out - = do size <- getConstructorAllocSize crepr + = do size <- getConstructorAllocSize crepr bindName tname (Just size) =<< foldM (flip bindPattern) out pats bindPattern (PatVar tname PatWild) out = bindName tname Nothing out @@ -208,7 +212,7 @@ chkApp (Con cname repr) args -- try reuse chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function = do bs <- getParamInfos (getName tname) withNonTail $ mapM_ chkArg $ zipParamInfo bs args - chkFunCallable (getName tname) =<< getFip + chkFunCallable (getName tname) input <- getInput unless (isTailContext input || getName tname `notElem` defGroupNames input) $ requireCapability mayRecurse $ \ppenv -> Just $ @@ -277,7 +281,7 @@ chkEffect tp {-------------------------------------------------------------------------- Chk monad --------------------------------------------------------------------------} -newtype Chk a = Chk (Env -> Input -> Result a) +type Chk a = ReaderT (Env, Input) (WriterT (Output, [Doc]) Unique) a data Env = Env{ currentDef :: [Def], prettyEnv :: Pretty.Env, @@ -292,21 +296,30 @@ data Input = Input{ delta :: S.Set Name, defGroupNames :: [Name], isTailContext :: Bool } +data AllocTree + = Alloc Id -- ^ allocation with unique identifier + | Call FipAlloc -- ^ call using allocation credits + | CallSelf FipAlloc -- ^ self-call using allocation credits + | Seq AllocTree AllocTree + | Match [AllocTree] + | Leaf + data Output = Output{ gammaNm :: M.Map TName Int, -- ^ matches variables to their number of uses - gammaDia :: M.Map Int [(Ratio Int, [TName])] } + gammaDia :: M.Map Int [(Ratio Int, [(TName,Id)])], -- ^ matches token size to allocations with a "probability" -- sorted in descending order of probability + allocTree :: AllocTree } instance Semigroup Output where - Output s1 m1 <> Output s2 m2 = - Output (M.unionWith (+) s1 s2) (M.unionWith (\x y -> sortOn (Down . fst) (x ++ y)) m1 m2) + Output s1 m1 t1 <> Output s2 m2 t2 = + Output (M.unionWith (+) s1 s2) (M.unionWith (\x y -> sortOn (Down . fst) (x ++ y)) m1 m2) (Seq t1 t2) instance Monoid Output where - mempty = Output M.empty M.empty + mempty = Output M.empty M.empty Leaf prettyGammaNm :: Pretty.Env -> Output -> Doc -prettyGammaNm ppenv (Output nm dia) +prettyGammaNm ppenv (Output nm dia _) = tupled $ map (\(nm, cnt) -> cat [ppName ppenv (getName nm), text "/", pretty cnt]) (M.toList nm) @@ -316,58 +329,37 @@ prettyCon ppenv tname sz = cat [ppName ppenv (getName tname), text "/", pretty (sz {-`div` 8-})] prettyGammaDia :: Pretty.Env -> Output -> Doc -prettyGammaDia ppenv (Output nm dia) +prettyGammaDia ppenv (Output nm dia _) = tupled $ concatMap - (\(sz, cs) -> map (\(_, c:_) -> prettyCon ppenv c sz) cs) + (\(sz, cs) -> map (\(_, (c,_):_) -> prettyCon ppenv c sz) cs) (M.toList dia) -data Result a = Ok a Output [Doc] - runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[Doc]) -runChk penv u platform newtypes borrowed gamma (Chk c) - = case c (Env [] penv platform newtypes borrowed gamma noFip) (Input S.empty [] True) of - Ok x _out docs -> (x,docs) - -instance Functor Chk where - fmap f (Chk c) = Chk (\env input -> case c env input of - Ok x out dgs -> Ok (f x) out dgs) - -instance Applicative Chk where - pure = return - (<*>) = ap - -instance Monad Chk where - return x = Chk (\env input -> Ok x mempty []) - (Chk c) >>= f = Chk (\env input -> case c env input of - Ok x out dgs -> case f x of - Chk d -> case d env input of - Ok x' out' dgs' -> Ok x' (out <> out') (dgs ++ dgs')) +runChk penv u platform newtypes borrowed gamma c + = fst $ runUnique 0 $ + fmap (fmap snd) $ runWriterT $ + runReaderT c (Env [] penv platform newtypes borrowed gamma noFip, Input S.empty [] True) withEnv :: (Env -> Env) -> Chk a -> Chk a -withEnv f (Chk c) - = Chk (\env st -> c (f env) st) +withEnv f = withReaderT (\(e, i) -> (f e, i)) getEnv :: Chk Env -getEnv - = Chk (\env st -> Ok env mempty []) +getEnv = asks fst withInput :: (Input -> Input) -> Chk a -> Chk a -withInput f (Chk c) - = Chk (\env st -> c env (f st)) +withInput f = withReaderT (\(e, i) -> (e, f i)) getInput :: Chk Input -getInput - = Chk (\env st -> Ok st mempty []) +getInput = asks snd writeOutput :: Output -> Chk () -writeOutput out - = Chk (\env st -> Ok () out []) +writeOutput out = tell (out, []) withFip :: Fip -> Chk a -> Chk a withFip f chk = withEnv (\env -> env{fip=f}) chk -getFip :: Chk Fip +getFip :: Chk Fip getFip = fip <$> getEnv mayRecurse :: Chk Bool @@ -385,50 +377,55 @@ mayDealloc Fip n -> False _ -> True -data AllocPermission - = Unlimited - | Limited FipAlloc - deriving (Eq, Ord) - -getAlloc :: Chk AllocPermission -getAlloc - = do fip <- getFip - pure $ case fip of - Fip n -> Limited n - Fbip n _ -> Limited n - NoFip _ -> Unlimited - mayAlloc :: Chk Bool -mayAlloc = (==Unlimited) <$> getAlloc +mayAlloc = (==AllocUnlimited) . fipAlloc <$> getFip isCallableFrom :: Fip -> Fip -> Bool -isCallableFrom (Fip _) _ = True -isCallableFrom (Fbip _ _) (Fbip _ _) = True -isCallableFrom (Fbip _ _) (NoFip _) = True -isCallableFrom (NoFip _) (NoFip _) = True -isCallableFrom _ _ = False - -chkFunCallable :: Name -> Fip -> Chk () -chkFunCallable fn fip - = do g <- gamma <$> getEnv - let xs = gammaLookupCanonical fn g - case xs of - [info] -> case info of - InfoFun _ _ _ _ fip' _ - -> if fip' `isCallableFrom` fip then pure () - else emitWarning $ text $ "Non-FIP function called: " ++ show fn - Type.Assumption.InfoExternal _ _ _ _ fip' _ - -> if fip' `isCallableFrom` fip then pure () - else emitWarning $ text $ "Non-FIP function called: " ++ show fn - _ -> pure () - [] -> emitWarning $ text $ "FIP analysis couldn't find FIP information for function: " ++ show fn - infos -> emitWarning $ text $ "FIP analysis found ambiguous FIP information for function: " ++ show fn ++ "\n" ++ show infos +isCallableFrom a b + = case (a, b) of + (Fip _, _) -> True + (Fbip _ _, Fbip _ _) -> True + (_, NoFip _) -> True + _ -> False + +writeCallAllocation :: Name -> Fip -> Chk () +writeCallAllocation fn fip + = do defs <- currentDefNames + let call = if fn `elem` defs then CallSelf else Call + case fip of + Fip n -> tell (Output mempty mempty (call n), mempty) + Fbip n _ -> tell (Output mempty mempty (call n), mempty) + NoFip _ -> pure () + +getFipInfo :: [NameInfo] -> Maybe Fip +getFipInfo xs + = case xs of + [info] -> case info of + InfoFun _ _ _ _ fip' _ + -> Just fip' + Type.Assumption.InfoExternal _ _ _ _ fip' _ + -> Just fip' + _ -> Nothing + infos -> Nothing + +chkFunCallable :: Name -> Chk () +chkFunCallable fn + = do fip <- getFip + g <- gamma <$> getEnv + case getFipInfo (gammaLookupCanonical fn g) of + Nothing + -> emitWarning $ text $ + "FIP analysis couldn't find FIP information for function: " ++ show fn + Just fip' + -> if fip' `isCallableFrom` fip then writeCallAllocation fn fip' + else emitWarning $ text $ "Non-FIP function called: " ++ show fn -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output -extractOutput (Chk f) - = Chk (\env st -> case f env st of - Ok () out doc -> Ok out mempty doc) +extractOutput f + = do ((), (out, doc)) <- censor (const mempty) $ listen f + tell (mempty, doc) + pure out -- | Perform a test if the capability is not present -- and emit a warning if the test is unsuccessful. @@ -475,7 +472,7 @@ isModConsFun expr TypeLam _ e -> isModConsFun e TypeApp e _ -> isModConsFun e Con _ _ -> True - Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModConsFun e + Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModConsFun e App f args -> hasTotalEffect (typeOf expr) && isModConsFun f && all isModCons args _ -> False @@ -497,7 +494,7 @@ markSeen tname info | infoIsRefCounted info -- is locally defined? when isHeapValue $ if b then requireCapability mayAlloc $ \ppenv -> Just $ cat [text "Borrowed value used as owned (can cause allocations later): ", ppName ppenv (getName tname)] - else writeOutput (Output (M.singleton tname 1) M.empty) + else writeOutput (Output (M.singleton tname 1) M.empty Leaf) markSeen tname info = chkWrap tname info -- wrap rule markBorrowed :: TName -> VarInfo -> Chk () @@ -512,7 +509,8 @@ markBorrowed nm info getAllocation :: TName -> Int -> Chk () getAllocation nm 0 = pure () getAllocation nm size - = writeOutput (Output mempty (M.singleton size [(1 % 1, [nm])])) + = do id <- lift $ lift $ uniqueId "alloc" + writeOutput (Output mempty (M.singleton size [(1 % 1, [(nm,id)])]) (Alloc id)) provideToken :: TName -> Int -> Output -> Chk Output provideToken _ 0 out = pure out @@ -539,7 +537,7 @@ joinContexts pats cs vcat $ text "Not all branches use the same variables:" : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs let unionDia = foldl1' (M.unionWith zipTokens) $ map (M.map (adjustProb (length cs')) . gammaDia) cs' - pure (Output unionNm unionDia) + pure (Output unionNm unionDia (Match (map allocTree cs'))) where adjustProb n xs = map (\(p, x) -> (p / (n%1), x) ) xs @@ -593,23 +591,70 @@ bindName nm msize out pure out pure (out { gammaNm = M.delete nm (gammaNm out) }) +data AllocInLoop = AllocInLoop + { hasAlloc :: Bool, + hasSelfCall :: Bool, + hasBothInSequence :: Bool } + +instance Semigroup AllocInLoop where + AllocInLoop a s b <> AllocInLoop a' s' b' + = AllocInLoop (a || a') (s || s') + (b || b' || (a && s') || (a' && s)) + +instance Monoid AllocInLoop where + mempty = AllocInLoop False False False + +joinBranches :: AllocInLoop -> AllocInLoop -> AllocInLoop +joinBranches (AllocInLoop a s b) (AllocInLoop a' s' b') + = AllocInLoop (a || a') (s || s') (b || b') + +getAllocCredits :: S.Set Id -> AllocTree -> (FipAlloc, AllocInLoop) +getAllocCredits notReused tree + = case tree of + Alloc id | id `S.member` notReused + -> (AllocAtMost 1, mempty { hasAlloc = True }) + | otherwise -> mempty + Call alloc -> (alloc, mempty) + CallSelf alloc -> (alloc, mempty { hasSelfCall = True }) + Seq a1 a2 -> getAllocCredits notReused a1 <> getAllocCredits notReused a2 + Match as -> foldl' (\(a, b) (a', b') -> (max a a', joinBranches b b')) mempty (map (getAllocCredits notReused) as) + Leaf -> mempty + +prettyFipAlloc :: FipAlloc -> String +prettyFipAlloc f + = case f of + AllocAtMost 0 -> "nothing" + AllocAtMost n -> "at most " ++ show n + AllocFinitely -> "a finite amount" + AllocUnlimited -> "unlimited" + checkOutputEmpty :: Output -> Chk () checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) -> emitWarning $ text $ "FIP analysis failed as it didn't bind a name: " ++ show nm - case M.maxViewWithKey $ gammaDia out of - Just ((sz, (_, c:cs):_), _) | sz > 0 - -> do permission <- getAlloc - case permission of - Limited (AllocAtMost n) - -> do unless (length (c:cs) <= n) $ do - env <- getEnv - emitWarning $ cat [text "Allocated constructor without reuse token: ", prettyCon (prettyEnv env) c sz] - Limited AllocFinitely -> pure () - Unlimited -> pure () - _ -> pure () + let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out + (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) + allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations + -- chkTrace $ show notReused + -- chkTrace $ show $ simplifyAllocTree (allocTree out) + permission <- fipAlloc <$> getFip + unless (allocations' <= permission) $ + emitWarning $ text $ "Function allocates " + ++ prettyFipAlloc allocations' + ++ " but was declared as allocating " + ++ prettyFipAlloc permission + +simplifyAllocTree :: AllocTree -> AllocTree +simplifyAllocTree (Seq a b) + = case (simplifyAllocTree a, simplifyAllocTree b) of + (Leaf, Leaf) -> Leaf + (Leaf, b) -> b + (a, Leaf) -> a + (a, b) -> Seq a b +simplifyAllocTree (Match as) = Match (map simplifyAllocTree as) +simplifyAllocTree t = t zipParamInfo :: [ParamInfo] -> [b] -> [(ParamInfo, b)] zipParamInfo xs = zip (xs ++ repeat Own) @@ -667,8 +712,7 @@ chkTrace msg trace ("chk: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () emitDoc :: Doc -> Chk () -emitDoc doc - = Chk (\env st -> Ok () mempty [doc]) +emitDoc doc = tell (mempty, [doc]) emitWarning :: Doc -> Chk () emitWarning doc @@ -680,4 +724,3 @@ getConstructorAllocSize :: ConRepr -> Chk Int getConstructorAllocSize conRepr = do platform <- getPlatform return (conReprAllocSize platform conRepr) - \ No newline at end of file From 16744d9390008182dd719dd2638ee2a06d953260 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Thu, 11 May 2023 17:51:23 -0700 Subject: [PATCH 181/233] Restore borrowing in match-scrutinee --- src/Core/CheckFBIP.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 07a40c378..b4d190a56 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -149,9 +149,11 @@ chkBranches scrutinees branches = do whichBorrowed <- mapM isBorrowedScrutinee scrutinees let branches' = filter (not . isPatternMatchError) branches outs <- mapM (extractOutput . chkBranch whichBorrowed) branches' - writeOutput =<< joinContexts (map branchPatterns branches') outs - withTailModProduct branches' $ -- also filter out pattern match errors - mapM_ chkScrutinee scrutinees + gamma2 <- joinContexts (map branchPatterns branches') outs + writeOutput gamma2 + withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ + withTailModProduct branches' $ -- also filter out pattern match errors + mapM_ chkScrutinee $ zip whichBorrowed scrutinees isBorrowedScrutinee :: Expr -> Chk ParamInfo isBorrowedScrutinee expr@(Var tname info) @@ -159,15 +161,13 @@ isBorrowedScrutinee expr@(Var tname info) pure $ if b then Borrow else Own isBorrowedScrutinee _ = pure Own -chkScrutinee :: Expr -> Chk () -chkScrutinee expr@(Var tname info) - = do b <- isBorrowed tname - unless b $ markSeen tname info -chkScrutinee expr = chkExpr expr +chkScrutinee :: (ParamInfo, Expr) -> Chk () +chkScrutinee (Borrow, Var tname info) = pure () +chkScrutinee (_, expr) = chkExpr expr chkBranch :: [ParamInfo] -> Branch -> Chk () chkBranch whichBorrowed (Branch pats guards) - = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zipParamInfo whichBorrowed pats + = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zip whichBorrowed pats outs <- withBorrowed (S.map getName $ bv $ map snd borPats) $ mapM (extractOutput . chkGuard) guards out <- joinContexts (repeat pats) outs @@ -253,7 +253,7 @@ chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - emitWarning $ text "FIP analysis detected that a top-level function was wrapped." + emitWarning $ text "A function with borrowed parameters is passed as an argument and implicitly wrapped." chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () @@ -489,12 +489,9 @@ isBorrowed nm markSeen :: TName -> VarInfo -> Chk () markSeen tname info | infoIsRefCounted info -- is locally defined? - = do b <- isBorrowed tname - isHeapValue <- needsDupDrop (tnameType tname) - when isHeapValue $ if b - then requireCapability mayAlloc $ \ppenv -> Just $ - cat [text "Borrowed value used as owned (can cause allocations later): ", ppName ppenv (getName tname)] - else writeOutput (Output (M.singleton tname 1) M.empty Leaf) + = do isHeapValue <- needsDupDrop (tnameType tname) + when isHeapValue $ + writeOutput (Output (M.singleton tname 1) M.empty Leaf) markSeen tname info = chkWrap tname info -- wrap rule markBorrowed :: TName -> VarInfo -> Chk () @@ -633,7 +630,7 @@ checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ text $ "FIP analysis failed as it didn't bind a name: " ++ show nm + -> emitWarning $ text $ "Unbound name (may have been used despite being borrowed): " ++ show nm let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations From b1b345121ab889c63312e4f0b94624bb8dd5a1cd Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 12 May 2023 09:15:44 -0700 Subject: [PATCH 182/233] Cleanup --- src/Core/CheckFBIP.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index b4d190a56..1c174b079 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -16,8 +16,7 @@ module Core.CheckFBIP( checkFBIP import qualified Lib.Trace import Control.Monad -import Control.Applicative -import Data.List( partition, intersperse, foldl1', foldl', isSuffixOf, uncons, sortBy ) +import Data.List (foldl', tails, uncons, isSuffixOf, foldl1', partition, sortOn) import qualified Data.Set as S import qualified Data.Map as M @@ -29,12 +28,9 @@ import Common.Unique import Common.Error import Common.Syntax -import Kind.Kind import Kind.Newtypes import Type.Type -import Type.Kind -import Type.TypeVar import Type.Pretty hiding (Env) import qualified Type.Pretty as Pretty import Type.Assumption @@ -46,13 +42,11 @@ import Core.Borrowed import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) import Backend.C.ParcReuse (getFixedDataAllocSize) import Backend.C.Parc (getDataDef') -import Data.List (tails, sortOn) import Data.Ratio -import Data.Ord (comparing, Down (Down)) +import Data.Ord (Down (Down)) import Control.Monad.Reader import Control.Monad.Writer import Common.Id -import Lib.Printer (Printer(write)) trace s x = Lib.Trace.trace s @@ -588,11 +582,15 @@ bindName nm msize out pure out pure (out { gammaNm = M.delete nm (gammaNm out) }) +-- | We record if the program has both an allocation +-- and a self-call which may be executed in sequence. +-- If that is the case, the program may use unlimited allocation. data AllocInLoop = AllocInLoop { hasAlloc :: Bool, hasSelfCall :: Bool, hasBothInSequence :: Bool } +-- | Sequential composition instance Semigroup AllocInLoop where AllocInLoop a s b <> AllocInLoop a' s' b' = AllocInLoop (a || a') (s || s') @@ -601,6 +599,7 @@ instance Semigroup AllocInLoop where instance Monoid AllocInLoop where mempty = AllocInLoop False False False +-- | Non-sequential composition joinBranches :: AllocInLoop -> AllocInLoop -> AllocInLoop joinBranches (AllocInLoop a s b) (AllocInLoop a' s' b') = AllocInLoop (a || a') (s || s') (b || b') @@ -608,8 +607,7 @@ joinBranches (AllocInLoop a s b) (AllocInLoop a' s' b') getAllocCredits :: S.Set Id -> AllocTree -> (FipAlloc, AllocInLoop) getAllocCredits notReused tree = case tree of - Alloc id | id `S.member` notReused - -> (AllocAtMost 1, mempty { hasAlloc = True }) + Alloc id | id `S.member` notReused -> (AllocAtMost 1, mempty { hasAlloc = True }) | otherwise -> mempty Call alloc -> (alloc, mempty) CallSelf alloc -> (alloc, mempty { hasSelfCall = True }) @@ -646,7 +644,6 @@ checkOutputEmpty out simplifyAllocTree :: AllocTree -> AllocTree simplifyAllocTree (Seq a b) = case (simplifyAllocTree a, simplifyAllocTree b) of - (Leaf, Leaf) -> Leaf (Leaf, b) -> b (a, Leaf) -> a (a, b) -> Seq a b From 97916d36fb63442848e204f0a843aa32f41599a6 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Fri, 12 May 2023 14:25:04 -0700 Subject: [PATCH 183/233] Cleanup & no warning for deallocating value types --- src/Core/CTail.hs | 5 ++--- src/Core/CheckFBIP.hs | 4 ++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index f0b4619c3..2817d5615 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -17,7 +17,6 @@ import Lib.Trace (trace) import Control.Monad import Control.Monad.Reader import Control.Monad.State -import Data.Char import Data.Maybe (catMaybes) import qualified Data.Set as S import qualified Data.IntMap as M @@ -25,9 +24,9 @@ import qualified Data.IntMap as M import Kind.Kind import Kind.Newtypes import Type.Type -import Type.Kind (effectIsAffine ) +import Type.Kind (effectIsAffine) import qualified Type.Pretty as Pretty -import Type.Assumption hiding (InfoExternal)-- Gamma +import Type.Assumption (Gamma) import Lib.PPrint import Common.NamePrim diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 1c174b079..6a6cb81a4 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -21,7 +21,6 @@ import qualified Data.Set as S import qualified Data.Map as M import Lib.PPrint -import Common.Failure import Common.Name import Common.Range import Common.Unique @@ -493,7 +492,8 @@ markBorrowed nm info = do b <- isBorrowed nm unless b $ do markSeen nm info - when (infoIsRefCounted info) $ + isHeapValue <- needsDupDrop (tnameType nm) + when (isHeapValue && infoIsRefCounted info) $ requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] From 34ca98c78fe63e2c8e4399fc04fe74844831049b Mon Sep 17 00:00:00 2001 From: daanx Date: Thu, 25 May 2023 19:04:02 -0700 Subject: [PATCH 184/233] wip: initial work on contexts --- kklib/include/kklib.h | 11 ++-- kklib/src/refcount.c | 4 +- lib/std/core/types-ctail-inline.h | 73 ------------------------- lib/std/core/types-ctail-inline.js | 30 ----------- lib/std/core/types.kk | 16 +++--- src/Backend/C/FromCore.hs | 24 ++++----- src/Backend/C/Parc.hs | 2 +- src/Backend/JavaScript/FromCore.hs | 8 +-- src/Common/NamePrim.hs | 35 +++++++++++- src/Core/CTail.hs | 87 +++++++++++++++--------------- src/Core/Core.hs | 4 +- src/Kind/Repr.hs | 2 +- src/Syntax/Lexer.x | 2 +- src/Syntax/Parse.hs | 6 +++ src/Type/Type.hs | 34 +++++++----- util/bundle.kk | 2 +- 16 files changed, 145 insertions(+), 195 deletions(-) delete mode 100644 lib/std/core/types-ctail-inline.h delete mode 100644 lib/std/core/types-ctail-inline.js diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 5bf967609..b8f110072 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1299,18 +1299,19 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) /*-------------------------------------------------------------------------------------- - TRMC (Further primitives are defined in `lib/std/core/types-ctail-inline.h`) + Constructor contexts (Further primitives are defined in `lib/std/core/types-cctx-inline.h`) --------------------------------------------------------------------------------------*/ #if !defined(KK_HAS_MALLOC_COPY) -#define KK_CTAIL_NO_CONTEXT_PATH +#define KK_CCTX_NO_CONTEXT_PATH #else -// functional context composition by copying along the context path and attaching `child` at the hole. -kk_decl_export kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx); +// functional context application by copying along the context path and attaching `child` at the hole. +kk_decl_export kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t child, kk_context_t* ctx); +// set the context path. // update the field_idx with the field index + 1 that is along the context path, and return `d` as is. -static inline kk_datatype_t kk_ctail_set_context_path(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { +static inline kk_datatype_t kk_cctx_setcp(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); kk_assert_internal(kk_datatype_is_ptr(d)); const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 2b486a0f0..e4b51bfeb 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -718,8 +718,8 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { } #endif -#if !defined(KK_CTAIL_NO_CONTEXT_PATH) -kk_decl_export kk_decl_noinline kk_box_t kk_ctail_context_copy_compose( kk_box_t res, kk_box_t child, kk_context_t* ctx) { +#if !defined(KK_CCTX_NO_CONTEXT_PATH) +kk_decl_export kk_decl_noinline kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t child, kk_context_t* ctx) { kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res, ctx))); kk_box_t cres = kk_box_null(); // copied result context kk_box_t* next = NULL; // pointer to the context path field in the parent block diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h deleted file mode 100644 index 4679bb6bd..000000000 --- a/lib/std/core/types-ctail-inline.h +++ /dev/null @@ -1,73 +0,0 @@ - - - - - - -/*--------------------------------------------------------------------------- - Copyright 2020-2021, Microsoft Research, Daan Leijen. - - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. A copy of the License can be - found in the LICENSE file at the root of this distribution. ----------------------------------------------------------------------------*/ - -static inline kk_box_t kk_ctail_hole(void) { - return kk_intf_box(0); -} - -static inline kk_std_core_types__ctail kk_ctail_unit(kk_context_t* ctx) { - return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, ctx); -} - - -static inline kk_box_t kk_ctail_apply_linear( kk_std_core_types__ctail acc, kk_box_t child ) { - #if 1 - if (kk_likely(acc.hole != NULL)) { - kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,kk_get_context()))); - *(acc.hole) = child; - return acc.res; - } - else { - return child; - } - #else - // this form entices conditional moves (but seems slower in general) - if (acc.hole != NULL) { *acc.hole = child; } - return (acc.hole != NULL ? acc.res : child); - #endif -} - -static inline kk_box_t kk_ctail_apply_nonlinear( kk_std_core_types__ctail acc, kk_box_t child, kk_context_t* ctx ) { - // note: written like this for best codegen; be careful when rewriting. - if (acc.hole != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))) { // no kk_likely seem slightly better - kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); - *(acc.hole) = child; // in-place update the hole with the child - return acc.res; - } - else if (kk_likely(acc.hole == NULL)) { - return child; - } - else { - kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); - return kk_ctail_context_copy_compose(acc.res,child,ctx); // copy the context path to the hole and compose with the child - } -} - -// apply a context to a child value -// is_linear is always a constant and set to `true` if the effect is guaranteed linear -static inline kk_box_t kk_ctail_apply( kk_std_core_types__ctail acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { - #if defined(KK_CTAIL_NO_CONTEXT_PATH) - return kk_ctail_apply_linear(acc,child); // compiler generates the right code for the non-linear case - #else - if (is_linear) return kk_ctail_apply_linear(acc,child); - else return kk_ctail_apply_nonlinear(acc,child,ctx); - #endif -} - -// compose a context to a new one -static inline kk_std_core_types__ctail kk_ctail_compose( kk_std_core_types__ctail acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { - return kk_std_core_types__new_CTail( kk_ctail_apply(acc,child,is_linear,ctx), field, ctx ); -} - - diff --git a/lib/std/core/types-ctail-inline.js b/lib/std/core/types-ctail-inline.js deleted file mode 100644 index 75ef17698..000000000 --- a/lib/std/core/types-ctail-inline.js +++ /dev/null @@ -1,30 +0,0 @@ -/*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. - - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. A copy of the License can be - found in the LICENSE file at the root of this distribution. ----------------------------------------------------------------------------*/ -export function _ctail_unit() { - return _CTail(undefined,{value:undefined,field:""}) -} - -export function _ctail_compose(acc,res,field) { - if (acc.res===undefined) { - return _CTail(res,field); - } - else { - acc.hole.value[acc.hole.field] = res; - return _CTail(acc.res,field); - } -} - -export function _ctail_apply(acc,res) { - if (acc.res===undefined) { - return res; - } - else { - acc.hole.value[acc.hole.field] = res; - return acc.res; - } -} diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index b5529c884..42f20aae5 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -362,19 +362,23 @@ pub value type optional // ---------------------------------------------------------------------------- +// First-class constructor contexts. // These primitives are used by the compiler for // _tail recursion module cons_ (TRMC) optimization. // ---------------------------------------------------------------------------- extern import - c header-end-file "types-ctail-inline.h" - js file "types-ctail-inline.js" + c header-end-file "types-cctx-inline.h" + js file "types-cctx-inline.js" // _Internal_. Internal type for _tail recursion module cons_ (TRMC) optimization. // Holds the address to a field of type `:a` in a constructor. -pub value type cfield +pub value type field-addr -// _Internal_. Internal type for _tail recursion module cons_ (TRMC) optimization. -abstract value type ctail - ".CTail"( res : a, hole : cfield ) +// First-class constructor context (for _tail recursion module cons_ (TRMC) optimization). +abstract value type cctxx + ".Cctx"( res : a, hole : field-addr ) + +// First-class constructor context. +pub alias cctx = cctxx diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 7f2e091f7..9059f20e5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1313,7 +1313,7 @@ cTypeCon c then CPrim "kk_box_t" else if (name == nameTpReuse) then CPrim "kk_reuse_t" - else if (name == nameTpCField) + else if (name == nameTpFieldAddr) then CPrim "kk_box_t*" else CData (typeClassName name) @@ -1897,23 +1897,23 @@ genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConF return (decls ++ [tmpDecl] ++ assigns, result) -- special: cfield-hole -genAppNormal (Var unbox _) [App (Var cfieldHole _) []] | getName cfieldHole == nameCFieldHole && getName unbox == nameUnbox +genAppNormal (Var unbox _) [App (Var cfieldHole _) []] | getName cfieldHole == nameCCtxHoleCreate && getName unbox == nameUnbox = return ([], genHoleCall (resultType (typeOf unbox))) -- ppType (resultType (typeOf unbox)) <.> text "_hole()") -- special: cfield-of -genAppNormal (Var cfieldOf _) [App (Var box _) [App (Var dup _) [Var con _]], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf && getName dup == nameDup +genAppNormal (Var cfieldOf _) [App (Var box _) [App (Var dup _) [Var con _]], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf && getName dup == nameDup = do let doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return ([],text "(kk_box_t*)" <.> parens doc) -genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf +genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf = do let drop = map (<.> semi) (genDupDropCall False (typeOf con) (ppName (getName con))) doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return (drop,text "(kk_box_t*)" <.> parens doc) --- special: ctail-set-context-path -genAppNormal (Var ctailSetContextPath _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName ctailSetContextPath == nameCTailSetCtxPath +-- special: cctx-set-context-path +genAppNormal (Var ctailSetContextPath _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName ctailSetContextPath == nameCCtxSetCtxPath = do (decl,conVar) <- genVarBinding conExpr - let doc = genCTailSetContextPath conVar (readQualified conName) (readQualified fieldName) + let doc = genCCtxSetContextPath conVar (readQualified conName) (readQualified fieldName) return ([decl],doc) -- add/sub small constant @@ -1979,9 +1979,9 @@ genFieldAddress :: TName -> Name -> Name -> Doc genFieldAddress conVar conName fieldName = parens (text "&" <.> conAsNameX (conName) <.> arguments [ppName (getName conVar)] <.> text "->" <.> ppName (unqualify fieldName)) -genCTailSetContextPath :: TName -> Name -> Name -> Doc -genCTailSetContextPath conVar conName fieldName - = text "kk_ctail_set_context_path" <.> +genCCtxSetContextPath :: TName -> Name -> Name -> Doc +genCCtxSetContextPath conVar conName fieldName + = text "kk_cctx_setcp" <.> arguments [-- conAsNameX conName, ppName (getName conVar), text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] @@ -2127,7 +2127,7 @@ genExprExternal tname formats [argDoc] | getName tname == nameReuse in return ([], call) -- special case: cfield hole -genExprExternal tname formats [] | getName tname == nameCFieldHole +genExprExternal tname formats [] | getName tname == nameCCtxHoleCreate = return ([], genHoleCall (resultType (typeOf tname))) -- ppType (resultType (typeOf tname)) <.> text "_hole()") {- @@ -2231,7 +2231,7 @@ isInlineableExpr expr Lit (LitString _)-> False -- C has no guarantee on argument evaluation so we only allow a select few operations to be inlined - App (Var v (InfoExternal _)) [] -> getName v `elem` [nameYielding,nameReuseNull,nameCFieldHole] + App (Var v (InfoExternal _)) [] -> getName v `elem` [nameYielding,nameReuseNull,nameCCtxHoleCreate] -- App (Var v (InfoExternal _)) [arg] | getName v `elem` [nameBox,nameDup,nameInt32] -> isInlineableExpr arg App (Var v _) [arg] | getName v `elem` [nameBox,nameInt32,nameReuse,nameReuseIsValid,nameIsUnique] -> isInlineableExpr arg diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 8bb8bc6ed..b9bad8058 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -591,7 +591,7 @@ getBoxForm' platform newtypes tp -> -- trace " 0 scan fields" $ case extractDataDefType tp of Just name - | name `elem` [nameTpInt, nameTpCField] || + | name `elem` [nameTpInt, nameTpFieldAddr] || ((name `elem` [nameTpInt8, nameTpInt16, nameTpFloat16]) && sizePtr platform > 2) || ((name `elem` [nameTpChar, nameTpInt32, nameTpFloat32]) && sizePtr platform > 4) -> BoxIdentity diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index 246f5addf..e38080ecc 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -698,8 +698,8 @@ genExpr expr App (Var tname _) [Lit (LitInt i)] | getName tname == nameInt64 && isSmallInt i -> return (empty, pretty i <.> text "n") - -- special: cfield-of - App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf + -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string + App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf -> do conDoc <- genTName con return (empty,text "{value:" <+> conDoc <.> text ", field: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") @@ -910,9 +910,9 @@ genExprExternal tname formats argDocs0 <.> text "()" in return ([],try) --- special case: cfield-hole +-- special case: .cctx-hole-create genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) -genExprExternalPrim tname formats [] | getName tname == nameCFieldHole +genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate = return ([],text "undefined") {- diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index 3b41d4048..68d3c5adf 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -70,15 +70,29 @@ module Common.NamePrim , nameAllocAt, nameConFieldsAssign, nameConTagFieldsAssign, nameReuseDrop , nameDropSpecial, nameKeep, nameSetTag - -- * CTail optimization - , nameTpCField, nameTpCTailAcc + -- * TRMC optimization, constructor contexts + , nameTpCCtxx, nameTpCCtx + , nameCCtxCreate + , nameCCtxHoleCreate + , nameCCtxEmpty + , nameCCtxApply + , nameCCtxExtend + , nameCCtxCompose + , nameCCtxSetCtxPath + , nameTpFieldAddr, nameFieldAddrOf + + {- + , nameTpCField, + , nameTpCTailAcc , nameCFieldHole + -- , nameCFieldSet , nameCFieldOf , nameCTailUnit , nameCTailCompose , nameCTailApply , nameCTailSetCtxPath + -} -- * Constructors , nameTrue, nameFalse @@ -268,6 +282,7 @@ nameTpMDict = qualify nameDict (newName "mdict") nameTpDict = qualify nameDict (newName "dict") nameTpBuilder = qualify (newName "std/text/string") (newName "builder") +{- nameTpCTailAcc = cfieldName "ctail" nameTpCField = cfieldName "cfield" nameCFieldHole = cfieldName ".cfield-hole" @@ -276,8 +291,24 @@ nameCTailUnit = cfieldName ".ctail-unit" nameCTailCompose = cfieldName ".ctail-compose" nameCTailApply = cfieldName ".ctail-apply" nameCTailSetCtxPath=cfieldName ".ctail-set-context-path" +-} + cfieldName name = coreTypesName name +nameTpCCtxx = cfieldName "cctxx" +nameTpCCtx = cfieldName "cctx" + +nameCCtxCreate = cfieldName ".cctx-create" +nameCCtxHoleCreate= cfieldName ".cctx-hole-create" +nameCCtxEmpty = cfieldName ".cctx-empty" +nameCCtxApply = cfieldName ".cctx-apply" +nameCCtxExtend = cfieldName ".cctx-extend" +nameCCtxCompose = cfieldName ".cctx-compose" +nameCCtxSetCtxPath= cfieldName ".cctx-setcp" + +nameTpFieldAddr = cfieldName "field-addr" +nameFieldAddrOf = cfieldName ".field-addr-of" + {-------------------------------------------------------------------------- std/core/hnd --------------------------------------------------------------------------} diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 2817d5615..daa90c94a 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -8,7 +8,9 @@ {-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Tail Recursive Modulo Cons implementation (called "ctail") +-- Tail Recursive Modulo Cons implementation +-- See: "Tail Recursion Modulo Context -- An Equational Approach", +-- Daan Leijen and Anton Lorenzen, POPL'22. ----------------------------------------------------------------------------- module Core.CTail ( ctailOptimize, uctailOptimize ) where @@ -89,8 +91,8 @@ ctailDef topLevel def Nothing -> return [DefRec [def]] Just (tforall,tpreds,targs,teff,tres) -> do -- ctailTrace "- has reference type result" - let ctailSlotType = TApp typeCTail [tres] - ctailName = makeHiddenName "ctail" (defName def) + let ctailSlotType = typeCCtx tres + ctailName = makeHiddenName "trmc" (defName def) ctailSlot = newHiddenName "acc" ctailType = tForall tforall tpreds (TFun (targs ++ [(ctailSlot,ctailSlotType)]) teff tres) ctailTName= TName ctailName ctailType @@ -104,7 +106,7 @@ ctailDef topLevel def let cdef = def{ defName = ctailName, defType = ctailType, defExpr = cdefExpr } needsMulti = not (useContextPath || alwaysAffine) ctailMultiSlotType = TFun [(nameNil,tres)] typeTotal tres - ctailMultiName = makeHiddenName "ctailm" (defName def) + ctailMultiName = makeHiddenName "trmcm" (defName def) ctailMultiSlot = newHiddenName "accm" ctailMultiType = tForall tforall tpreds (TFun (targs ++ [(ctailMultiSlot,ctailMultiSlotType)]) teff tres) ctailMultiTName = TName ctailMultiName ctailMultiType @@ -166,7 +168,7 @@ ctailWrapperBody :: Type -> TName -> Maybe Expr -> [TypeVar] -> [TName] -> CTail ctailWrapperBody resTp slot mbMulti targs args = do tailVar <- getCTailFun let ctailCall = App (makeTypeApp tailVar [TVar tv | tv <- targs]) - ([Var name InfoNone | name <- args] ++ [makeCTailUnit resTp]) + ([Var name InfoNone | name <- args] ++ [makeCCtxEmpty resTp]) case mbMulti of Nothing -> return ctailCall Just ctailMultiVar @@ -245,7 +247,7 @@ ctailExpr top expr case (expr',mbSlot) of (App v@(Var ctailmSlot _) [arg], Just slot) | getName ctailmSlot == getName slot -> return (App v [TypeApp arg targs]) -- push down typeapp - (App v@(TypeApp (Var ctailApply _) _) [acc,arg],_) | getName ctailApply == nameCTailApply + (App v@(TypeApp (Var ctailApply _) _) [acc,arg],_) | getName ctailApply == nameCCtxApply -> return (App v [acc,TypeApp arg targs]) -- push down typeapp into ctail set _ -> return (TypeApp expr' targs) @@ -270,7 +272,7 @@ ctailExpr top expr Nothing -> return body Just slot -> do isMulti <- getIsMulti alwaysAffine <- getIsAlwaysAffine - return (makeCTailApply isMulti alwaysAffine slot body) + return (makeCCtxApply isMulti alwaysAffine slot body) handleConApp dname cname fcon fargs = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) @@ -374,7 +376,7 @@ setContextPathExpr cname field case fieldInfo of Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 Right (_,fieldName) -> - return (\parent -> makeCSetContextPath (Var parent InfoNone) cname fieldName) + return (\parent -> makeCCtxSetContextPath (Var parent InfoNone) cname fieldName) @@ -404,11 +406,11 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 Right (_,fieldName) -> do let -- tp = typeOf (App f fargs) - hole = makeCFieldHole resTp + hole = makeHole resTp (defs,cons) <- mkConsApp [hole] consName <- uniqueTName (typeOf cons) alwaysAffine <- getIsAlwaysAffine - let comp = makeCTailCompose slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine + let comp = makeCCtxExtend slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine ctailCall = mkTailApp ctailVar comp return $ (defs ++ [DefNonRec (makeTDef consName cons)] ,ctailCall) @@ -419,78 +421,79 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs -------------------------------------------------------------------------- -- Polymorphic hole -makeCFieldHole :: Type -> Expr -makeCFieldHole tp - = App (TypeApp (Var (TName nameCFieldHole funType) (InfoExternal [])) [tp]) [] +makeHole :: Type -> Expr +makeHole tp + = App (TypeApp (Var (TName nameCCtxHoleCreate funType) (InfoExternal [])) [tp]) [] where funType = TForall [a] [] (TFun [] typeTotal (TVar a)) a = TypeVar 0 kindStar Bound -- Initial empty context (@ctx hole) -makeCTailUnit :: Type -> Expr -makeCTailUnit tp - = App (TypeApp (Var (TName nameCTailUnit funType) +makeCCtxEmpty :: Type -> Expr +makeCCtxEmpty tp + = App (TypeApp (Var (TName nameCCtxEmpty funType) -- (InfoArity 1 0) - (InfoExternal [(C CDefault,"kk_ctail_unit(kk_context())"),(JS JsDefault,"$std_core_types._ctail_unit()")]) + (InfoExternal [(C CDefault,"kk_cctx_empty(kk_context())"),(JS JsDefault,"$std_core_types._cctx_empty()")]) ) [tp]) [] where - funType = TForall [a] [] (TFun [] typeTotal (TApp typeCTail [TVar a])) + funType = TForall [a] [] (TFun [] typeTotal (typeCCtx (TVar a))) a = TypeVar 0 kindStar Bound -- The adress of a field in a constructor (for context holes) -makeCFieldOf :: TName -> TName -> Name -> Type -> Expr -makeCFieldOf objName conName fieldName tp - = App (TypeApp (Var (TName nameCFieldOf funType) (InfoExternal [])) [tp]) +makeFieldAddrOf :: TName -> TName -> Name -> Type -> Expr +makeFieldAddrOf objName conName fieldName tp + = App (TypeApp (Var (TName nameFieldAddrOf funType) (InfoExternal [])) [tp]) [Var objName InfoNone, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] where funType = TForall [a] [] (TFun [(nameNil,TVar a),(nameNil,typeString),(nameNil,typeString)] - typeTotal (TApp typeCField [TVar a])) + typeTotal (TApp typeFieldAddr [TVar a])) a = TypeVar 0 kindStar Bound --- Compose two contexts -makeCTailCompose :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr -makeCTailCompose slot resName objName conName fieldName tp alwaysAffine - = let fieldOf = makeCFieldOf objName conName fieldName tp - in App (TypeApp (Var (TName nameCTailCompose funType) +-- Extend a context with a non-empty context +makeCCtxExtend :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr +makeCCtxExtend slot resName objName conName fieldName tp alwaysAffine + = let fieldOf = makeFieldAddrOf objName conName fieldName tp + in App (TypeApp (Var (TName nameCCtxExtend funType) -- (InfoArity 1 3) - (InfoExternal [(C CDefault,"kk_ctail_compose(#1,#2,#3," ++ affine ++ ",kk_context())"), - (JS JsDefault,"$std_core_types._ctail_compose(#1,#2,#3)")]) + (InfoExternal [(C CDefault,"kk_cctx_extend(#1,#2,#3," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._cctx_extend(#1,#2,#3)")]) ) [tp]) [Var slot InfoNone, Var resName InfoNone, fieldOf] where affine = if alwaysAffine then "true" else "false" - funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]), + funType = TForall [a] [] (TFun [(nameNil,typeCCtx (TVar a)), (nameNil,TVar a), - (nameNil,TApp typeCField [TVar a])] typeTotal (TApp typeCTail [TVar a])) + (nameNil,TApp typeFieldAddr [TVar a])] typeTotal (typeCCtx (TVar a))) a = TypeVar 0 kindStar Bound -- Apply a context to its final value. -makeCTailApply :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr -makeCTailApply True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve +makeCCtxApply :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr +makeCCtxApply True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve = App (Var slot InfoNone) [expr] -makeCTailApply False alwaysAffine slot expr -- slot is a `ctail` - = App (TypeApp (Var (TName nameCTailApply funType) +makeCCtxApply False alwaysAffine slot expr -- slot is a `ctail` + = App (TypeApp (Var (TName nameCCtxApply funType) -- (InfoArity 1 2) - (InfoExternal [(C CDefault,"kk_ctail_apply(#1,#2," ++ affine ++ ",kk_context())"), - (JS JsDefault,"$std_core_types._ctail_apply(#1,#2)")]) + (InfoExternal [(C CDefault,"kk_cctx_apply(#1,#2," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._cctx_apply(#1,#2)")]) ) [tp]) [Var slot InfoNone, expr] where affine = if alwaysAffine then "true" else "false" tp = case typeOf slot of TApp _ [t] -> t - funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]),(nameNil,TVar a)] typeTotal (TVar a)) + TSyn _ [t] _ -> t + funType = TForall [a] [] (TFun [(nameNil,typeCCtx (TVar a)),(nameNil,TVar a)] typeTotal (TVar a)) a = TypeVar (-1) kindStar Bound -- Set the index of the field in a constructor to follow the path to the hole at runtime. -makeCSetContextPath :: Expr -> TName -> Name -> Expr -makeCSetContextPath obj conName fieldName - = App (Var (TName nameCTailSetCtxPath funType) (InfoExternal [(Default,".ctail-set-context-path(#1,#2,#3)")])) +makeCCtxSetContextPath :: Expr -> TName -> Name -> Expr +makeCCtxSetContextPath obj conName fieldName + = App (Var (TName nameCCtxSetCtxPath funType) (InfoExternal [(Default,".cctx-setcp(#1,#2,#3)")])) [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] where tp = typeOf obj @@ -503,7 +506,7 @@ makeCSetContextPath obj conName fieldName -- create a unique name specific to this module uniqueTName :: Type -> CTail TName -uniqueTName tp = (`TName` tp) <$> uniqueName "ctail" +uniqueTName tp = (`TName` tp) <$> uniqueName "trmc" -- for mapping over a set and collecting the results into a list. foldMapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 80d9cf7c6..c1c4a0633 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -122,7 +122,7 @@ import Common.Id import Common.Error import Common.NamePrim( nameTrue, nameFalse, nameTuple, nameTpBool, nameEffectOpen, nameReturn, nameTrace, nameLog, nameEvvIndex, nameOpenAt, nameOpenNone, nameInt32, nameSSizeT, nameBox, nameUnbox, - nameVector, nameCons, nameNull, nameTpList, nameUnit, nameTpUnit, nameTpCField, + nameVector, nameCons, nameNull, nameTpList, nameUnit, nameTpUnit, nameTpFieldAddr, isPrimitiveName, isSystemCoreName, nameKeep, nameDropSpecial) import Common.Syntax import Kind.Kind @@ -452,7 +452,7 @@ getDataReprEx getIsValue info -- else if (hasExistentials) -- then (DataNormal, map (\con -> ConNormal typeName) conInfos) else if (isValue - && (null (dataInfoParams info) || typeName == nameTpCField) + && (null (dataInfoParams info) || typeName == nameTpFieldAddr) && all (\con -> null (conInfoParams con)) conInfos) then (DataEnum,map (\ci -> ConEnum typeName DataEnum (conInfoValueRepr ci)) conInfos) else if (length conInfos == 1) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 273c8fbec..18d3d8055 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -137,7 +137,7 @@ createDataDef emitError emitWarning lookupDataInfo then 1 else if (name == nameTpInt16 || name == nameTpFloat16) then 2 - else if (name == nameTpAny || name == nameTpCField || name == nameTpIntPtrT) + else if (name == nameTpAny || name == nameTpFieldAddr || name == nameTpIntPtrT) then (sizePtr platform) else if (name==nameTpSSizeT) then (sizeSize platform) diff --git a/src/Syntax/Lexer.x b/src/Syntax/Lexer.x index c7055dda1..45c919430 100644 --- a/src/Syntax/Lexer.x +++ b/src/Syntax/Lexer.x @@ -290,7 +290,7 @@ reservedNames , "val", "fun", "fn", "extern", "var" , "ctl", "final", "raw" , "if", "then", "else", "elif" - , "return", "match", "with", "in" + , "return", "match", "with", "in", "ctx" , "forall", "exists", "some" , "pub", "abstract" , "module", "import", "as" diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 9e14b6377..26d349dbd 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -2003,6 +2003,12 @@ listExpr makeNil rng = Var nameNull False rng makeCons rng x xs = makeApp (Var nameCons False rng) [x,xs] +cctxExpr :: LexParser UserExpr +cctxExpr + = do rng <- keyword "ctx" + ctx <- ntlexpr + return (makeApp (Var nameCCtxCreate False rng) [ctx]) + injectExpr :: LexParser UserExpr injectExpr diff --git a/src/Type/Type.hs b/src/Type/Type.hs index 50f02229a..580f6a884 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -42,7 +42,7 @@ module Type.Type (-- * Types , typeDivergent, typeTotal, typePartial , typeList, typeVector, typeApp, typeRef, typeNull, typeOptional, typeMakeTuple - , typeCTail, typeCField + , typeCCtx, typeCCtxx, typeFieldAddr , isOptional, makeOptional, unOptional , typeReuse, typeLocal @@ -778,22 +778,30 @@ isTypeUnit _ = False -- | Type of ctail -typeCTail :: Tau -typeCTail - = TCon tconCTail +typeCCtx :: Tau -> Tau +typeCCtx tp + = TSyn tsynCCtx [tp] (TApp typeCCtxx [tp,tp]) -tconCTail :: TypeCon -tconCTail - = TypeCon nameTpCTailAcc (kindFun kindStar kindStar) +tsynCCtx :: TypeSyn +tsynCCtx + = TypeSyn nameTpCCtx (kindFun kindStar kindStar) 0 Nothing + +typeCCtxx :: Tau +typeCCtxx + = TCon tconCCtxx + +tconCCtxx :: TypeCon +tconCCtxx + = TypeCon nameTpCCtxx (kindFun kindStar (kindFun kindStar kindStar)) -- | Type of cfield -typeCField :: Tau -typeCField - = TCon tconCField +typeFieldAddr :: Tau +typeFieldAddr + = TCon tconFieldAddr -tconCField :: TypeCon -tconCField - = TypeCon nameTpCField (kindFun kindStar kindStar) +tconFieldAddr :: TypeCon +tconFieldAddr + = TypeCon nameTpFieldAddr (kindFun kindStar kindStar) -- | Type of vectors (@[]@) typeVector :: Tau diff --git a/util/bundle.kk b/util/bundle.kk index c661907a8..bed005366 100644 --- a/util/bundle.kk +++ b/util/bundle.kk @@ -14,7 +14,7 @@ import std/os/flags import std/time/time import std/time/utc -val header = "usage:\n stack exec koka -- util/bundle [-- [options]]\n\noptions:" +val header = "usage:\n stack exec koka -- -e util/bundle [-- [options]]\n\noptions:" struct iflags prefixdir : string = "" From 857248da46188e28fe71a5d267b1110abe98bbab Mon Sep 17 00:00:00 2001 From: daanx Date: Thu, 25 May 2023 19:33:57 -0700 Subject: [PATCH 185/233] contexts: fix js compilation --- src/Backend/JavaScript/FromCore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index e38080ecc..1e2471334 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -701,7 +701,7 @@ genExpr expr -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf -> do conDoc <- genTName con - return (empty,text "{value:" <+> conDoc <.> text ", field: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") + return (empty,text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") App f args -> {- case splitFunScheme (typeOf f) of From 014e64f6bbf2abf0d7d9b7c3b6e609691fa84f36 Mon Sep 17 00:00:00 2001 From: daanx Date: Thu, 25 May 2023 23:07:41 -0700 Subject: [PATCH 186/233] wip: initial context expressions with context paths --- koka.cabal | 1 + lib/std/core/types.kk | 37 ++++- src/Core/AnalysisCCtx.hs | 287 +++++++++++++++++++++++++++++++++++++++ src/Syntax/Lexer.x | 3 +- src/Syntax/Parse.hs | 9 ++ src/Type/Infer.hs | 11 ++ 6 files changed, 345 insertions(+), 3 deletions(-) create mode 100644 src/Core/AnalysisCCtx.hs diff --git a/koka.cabal b/koka.cabal index d030534ae..22c415ca9 100644 --- a/koka.cabal +++ b/koka.cabal @@ -53,6 +53,7 @@ executable koka Compiler.Module Compiler.Options Compiler.Package + Core.AnalysisCCtx Core.AnalysisMatch Core.AnalysisResume Core.BindingGroups diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 42f20aae5..e2128b462 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -372,13 +372,46 @@ extern import js file "types-cctx-inline.js" -// _Internal_. Internal type for _tail recursion module cons_ (TRMC) optimization. +// _Internal_. Internal type for constructor contexts. // Holds the address to a field of type `:a` in a constructor. pub value type field-addr // First-class constructor context (for _tail recursion module cons_ (TRMC) optimization). abstract value type cctxx - ".Cctx"( res : a, hole : field-addr ) + ".Cctx"( res : a, holeptr : field-addr ) // First-class constructor context. pub alias cctx = cctxx + +// _Internal_. Create a hole for a context +pub inline extern ".cctx-hole-create"() : e a + c inline "kk_intf_box(0)" + js inline "undefined" + +// _Internal_. Create an initial non-empty context. +pub extern ".cctx-create"( x : a, xhole : field-addr ) : cctxx + c "kk_cctx_create" + js "_cctx_create" + +// _Internal_. Extend a constructor context with a non-empty context +pub inline extern ".cctx-extend"( c : cctxx, x : b, xhole : field-addr ) : cctxx + c inline "kk_cctx_apply(#1,#2,#3,false /*is-linear*/,kk_context())" + js "_cctx_extend" + + +// Apply a constructor context +pub inline extern []( c : cctxx, x : b ) : a + c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_apply" + +// Compose two constructor contexts. +pub inline extern cctx-compose( c1 : cctxx, c2 : cctxx ) : cctxx + c inline "kk_cctx_compose(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_compose" + +// Create an empty context +pub inline extern cctx-empty() : cctxx + c "kk_cctx_empty" + js "_cctx_empty" + + diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs new file mode 100644 index 000000000..60f69a430 --- /dev/null +++ b/src/Core/AnalysisCCtx.hs @@ -0,0 +1,287 @@ +----------------------------------------------------------------------------- +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +{- + Check if a constructor context is well formed, and create a context path +-} + +module Core.AnalysisCCtx( analyzeCCtx, + + makeCCtxEmpty, + makeCCtxCreate, + makeCCtxSetContextPath, + makeFieldAddrOf + -- getFieldName + ) where + + +import Control.Monad +import Lib.Trace +import Lib.PPrint +import Common.Syntax( Target(..), JsTarget(..), CTarget(..) ) +import Common.Id +import Common.Name +import Common.NamePrim(nameCCtxHoleCreate,nameCCtxCreate,nameCCtxEmpty,nameCCtxSetCtxPath,nameFieldAddrOf,nameTpFieldAddr) +import Common.Range +import Common.Unique(HasUnique(..)) +import Common.Failure +import Kind.Newtypes +import Kind.Kind +import Type.Type +import Type.Pretty as Pretty +import Type.TypeVar +import Core.Core +import Core.Pretty + +-- take a context and check if it is well-formed and return a well-typed context expression +analyzeCCtx :: Range -> Newtypes -> Expr -> Either [(Range,Doc)] Expr +analyzeCCtx rng newtypes expr + = runCCtx rng newtypes 0 (cctxCreate expr) + + +data Hole = Hole{ holeAddr :: Expr, holeType :: Type } +data Ctx = Ctx{ defs :: [Def], top :: Expr, hole :: Hole } + +cctxCreate :: Expr -> CCtx Expr +-- empty context? +cctxCreate expr | isHole expr + = do return (makeCCtxEmpty (typeOf expr)) +-- non-empty context +cctxCreate expr + = do mtrace ("expr: " ++ show expr) + (Ctx defs top (Hole addr holetp)) <- cctxExpr expr + let tp = typeOf top + let cctx = makeCCtxCreate tp holetp top addr + return (Let (map DefNonRec defs) cctx) + + +cctxExpr :: Expr -> CCtx Ctx +cctxExpr expr + = case expr of + -- constructor + App con@(Con name repr) args | not (null args) + -> cctxCon name repr [] args + + App (TypeApp (con@(Con name repr)) targs) args | not (null args) + -> cctxCon name repr targs args + + _ -> illegal + + {- + Var _ _ -> illegal "var" + Lam _ _ _ -> illegal "lambda" + TypeLam _ e -> illegal "" + Lit _ -> illegal + Let dgs e -> + Case _ _ -> + App _ _ -> + -} + +-- todo: check dataRepr for non-value constructor +cctxCon :: TName -> ConRepr -> [Type] -> [Expr] -> CCtx Ctx +cctxCon conName conRepr targs args + = case span (not . isHole) args of + (pre,hole:post) + -> cctxConFinal conName conRepr targs pre hole post + _ -> cctxConRecurse conName conRepr targs args + +cctxConRecurse :: TName -> ConRepr -> [Type] -> [Expr] -> CCtx Ctx +cctxConRecurse conName conRepr targs args + = do (pre,ctx,post) <- cctxFind [] args + mapM_ cctxCheckNoHole (pre ++ post) + (ds,vars) <- unzip <$> mapM makeUniqueDef pre + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (vars ++ [top ctx] ++ post)) + fname <- getFieldName conName (length pre + 1) + (d2,var2) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) + return (ctx{ defs = ds ++ defs ctx ++ [d1,d2], top = var2 }) + +cctxConFinal :: TName -> ConRepr -> [Type] -> [Expr] -> Expr -> [Expr] -> CCtx Ctx +cctxConFinal conName conRepr targs pre hole post + = do mapM_ cctxCheckNoHole (pre ++ post) + fname <- getFieldName conName (length pre + 1) + let holetp = typeOf hole + (d1,var) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) + (d2,addr) <- makeUniqueDef (makeFieldAddrOf var conName fname holetp) + return (Ctx [d1,d2] var (Hole addr holetp)) + +cctxCheckNoHole :: Expr -> CCtx () +cctxCheckNoHole expr + = -- todo: check no holes in expr + return () + + +cctxFind :: [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) +-- no args +cctxFind acc [] = illegal +-- try recursively +cctxFind acc (arg:args) + = do r <- try (cctxExpr arg) + case r of + Left _ -> cctxFind (arg:acc) args + Right ctx -> return (reverse acc,ctx,args) + + +illegal + = emitErrors [] + +makeUniqueDef :: Expr -> CCtx (Def,Expr) +makeUniqueDef expr + = do name <- uniqueName "cctx" + return (makeDef name expr, Var (TName name (typeOf expr)) InfoNone) + +isHole :: Expr -> Bool +isHole (App (TypeApp (Var (TName hname htp) _) [tp,_etp]) []) = (hname == nameCCtxHoleCreate) +isHole _ = False + +-- Initial empty context (ctx hole) +makeCCtxEmpty :: Type -> Expr +makeCCtxEmpty tp + = App (TypeApp (Var (TName nameCCtxEmpty funType) + -- (InfoArity 1 0) + (InfoExternal [(C CDefault,"kk_cctx_empty(kk_context())"),(JS JsDefault,"$std_core_types._cctx_empty()")]) + ) [tp]) [] + where + funType = TForall [a] [] (TFun [] typeTotal (typeCCtx (TVar a))) + a = TypeVar 0 kindStar Bound + + +-- Create a context (ctx Cons(e,Cons(2,hole))) +makeCCtxCreate :: Type -> Type -> Expr -> Expr -> Expr +makeCCtxCreate tp holetp top holeaddr + = App (TypeApp (Var (TName nameCCtxCreate funType) + -- (InfoArity 1 3) + (InfoExternal [(C CDefault,"kk_cctx_create(#1,#2,kk_context())"), + (JS JsDefault,"$std_core_types._cctx_create(#1,#2)")]) + ) [tp,holetp]) [top,holeaddr] + where + funType = TForall [a,b] [] (TFun [(nameNil,TVar a), + (nameNil,TApp typeFieldAddr [TVar a])] + typeTotal (TApp typeCCtxx [TVar a,TVar b])) + a = TypeVar 0 kindStar Bound + b = TypeVar 1 kindStar Bound + + +-- The adress of a field in a constructor (for context holes) +makeFieldAddrOf :: Expr -> TName -> Name -> Type -> Expr +makeFieldAddrOf obj conName fieldName fieldTp + = App (TypeApp (Var (TName nameFieldAddrOf funType) (InfoExternal [])) [fieldTp]) + [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] + where + funType = TForall [a] [] (TFun [(nameNil,TVar a),(nameNil,typeString),(nameNil,typeString)] + typeTotal (TApp typeFieldAddr [TVar a])) + a = TypeVar 0 kindStar Bound + +-- Set the index of the field in a constructor to follow the path to the hole at runtime. +makeCCtxSetContextPath :: Expr -> TName -> Name -> Expr +makeCCtxSetContextPath obj conName fieldName + = App (Var (TName nameCCtxSetCtxPath funType) (InfoExternal [(Default,".cctx-setcp(#1,#2,#3)")])) + [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] + where + tp = typeOf obj + funType = (TFun [(nameNil,tp),(nameNil,typeString),(nameNil,typeString)] typeTotal tp) + + +{-------------------------------------------------------------------------- + CC Monad +--------------------------------------------------------------------------} + +newtype CCtx a = CCtx (Int -> CCtxEnv -> Result a) + +runCCtx :: Range -> Newtypes -> Int -> CCtx a -> Either [(Range,Doc)] a +runCCtx rng nt uniq (CCtx c) + = case (c uniq (CCtxEnv rng nt)) of + Ok x u' -> Right x + Err errs -> Left errs + + + +data CCtxEnv = CCtxEnv{ rng :: Range, newtypes :: Newtypes } + +data Result a = Err [(Range,Doc)] + | Ok a Int + +instance Functor CCtx where + fmap f (CCtx c) = CCtx (\u env -> case c u env of + Ok x u' -> Ok (f x) u' + Err errs -> Err errs) + +instance Applicative CCtx where + pure = return + (<*>) = ap + +instance Monad CCtx where + return x = CCtx (\u g -> Ok x u) + (CCtx c) >>= f = CCtx (\u g -> case c u g of + Ok x u' -> case f x of + CCtx d -> d u' g + Err errs -> Err errs) + +instance HasUnique CCtx where + updateUnique f = CCtx (\u g -> Ok u (f u)) + setUnique i = CCtx (\u g -> Ok () i) + +getEnv :: CCtx CCtxEnv +getEnv + = CCtx (\u g -> Ok g u) + +withEnv :: CCtxEnv -> CCtx a -> CCtx a +withEnv env (CCtx c) + = CCtx (\u _ -> c u env) + +updateEnv :: (CCtxEnv -> CCtxEnv) -> CCtx a -> CCtx a +updateEnv f (CCtx c) + = CCtx (\u env -> c u (f env)) + +emitErrors :: [Doc] -> CCtx a +emitErrors errs + = do env <- getEnv + CCtx (\u env -> Err [(rng env,d) | d <- errs]) + + +try :: CCtx a -> CCtx (Either [(Range,Doc)] a) +try (CCtx c) + = CCtx (\u env -> case c u env of + Ok x u' -> Ok (Right x) u' + Err errs -> Ok (Left errs) u) + + +mtrace :: String -> CCtx () +mtrace msg + = do env <- getEnv + trace ("Core.AnalysisCCtx: " ++ msg) $ + return () + +getFieldName :: TName -> Int -> CCtx Name +getFieldName cname fieldIdx + = do info <- lookupFieldName cname fieldIdx + case info of + Left err -> failure ("Core.AnalysisCCtx: " ++ err) + Right name -> return name + +lookupFieldName :: TName -> Int -> CCtx (Either String Name) +lookupFieldName cname field + = do env <- getEnv + case newtypesLookupAny (getDataTypeName cname) (newtypes env) of + Just dataInfo -> + do let (dataRepr,_) = getDataRepr dataInfo + if (dataReprIsValue dataRepr) + then return (Left ("contexts cannot go through a value type (" ++ show (getName cname) ++ ")")) + else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of + [con] -> case drop (field - 1) (conInfoParams con) of + ((fname,ftp):_) -> return $ Right fname {- Con cname (getConRepr dataInfo con), fname) -} + _ -> failure $ "Core.CTail.getFieldName: field index is off: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (conInfoParams con) + _ -> failure $ "Core.CTail.getFieldName: cannot find constructor: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (dataInfoConstrs dataInfo) + _ -> failure $ "Core.CTail.getFieldName: no such constructor: " ++ show cname ++ ", field " ++ show field + where + getDataTypeName cname = case splitFunScheme (typeOf cname) of + Just (_,_,_,_,tres) -> getDataTypeNameRes tres + Nothing -> failure $ "Core.CTail.getFieldName: illegal constructor type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) + getDataTypeNameRes tp = case expandSyn tp of + TApp t ts -> getDataTypeNameRes t + TCon tc -> typeConName tc + _ -> failure $ "Core.CTail.getFieldName: illegal result type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) diff --git a/src/Syntax/Lexer.x b/src/Syntax/Lexer.x index 45c919430..380d1ce59 100644 --- a/src/Syntax/Lexer.x +++ b/src/Syntax/Lexer.x @@ -290,7 +290,8 @@ reservedNames , "val", "fun", "fn", "extern", "var" , "ctl", "final", "raw" , "if", "then", "else", "elif" - , "return", "match", "with", "in", "ctx" + , "return", "match", "with", "in" + , "ctx", "hole" , "forall", "exists", "some" , "pub", "abstract" , "module", "import", "as" diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 26d349dbd..9b1c2782c 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -1951,6 +1951,10 @@ atom <|> do lit <- literal return (Lit lit) + <|> + do cctxHole + <|> + do cctxExpr <|> do injectExpr "(simple) expression" @@ -2008,6 +2012,11 @@ cctxExpr = do rng <- keyword "ctx" ctx <- ntlexpr return (makeApp (Var nameCCtxCreate False rng) [ctx]) + +cctxHole :: LexParser UserExpr +cctxHole + = do rng <- keyword "hole" + return (makeApp (Var nameCCtxHoleCreate False rng) []) injectExpr :: LexParser UserExpr diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index c3ecd826e..7b2c9f514 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -39,6 +39,7 @@ import Common.NamePrim( nameTpOptional, nameOptional, nameOptionalNone, nameCopy , nameTpValueOp, nameClause, nameIdentity , nameMaskAt, nameMaskBuiltin, nameEvvIndex, nameHTag, nameTpHTag , nameInt32, nameOr, nameAnd, nameEffectOpen + , nameCCtxCreate ) import Common.Range import Common.Unique @@ -65,6 +66,7 @@ import Type.InferMonad import qualified Core.CoreVar as CoreVar import Core.AnalysisMatch( analyzeBranches ) +import Core.AnalysisCCtx( analyzeCCtx ) -- import Common.ResumeKind -- import Core.AnalysisResume( analyzeResume ) import Core.Divergent( analyzeDivergence ) @@ -709,6 +711,15 @@ inferExpr propagated expect (App (h@Handler{hndlrAllowMask=Nothing}) [action] rn inferExpr propagated expect (App (Var byref _ _) [(_,Var name _ rng)] _) | byref == nameByref = inferVar propagated expect name rng False +-- | Context expressions +inferExpr propagated expect (App (Var ctxname _ nameRng) [(_,expr)] rng) | ctxname == nameCCtxCreate + = do (tp,eff,core) <- inferExpr Nothing -- todo: propagate through cctx + Instantiated expr + newtypes <- getNewtypes + case analyzeCCtx rng newtypes core of + Left errs -> failure ("Type.Infer.context") + Right ccore -> return (Core.typeOf ccore,eff,ccore) + -- | Application nodes. Inference is complicated here since we need to disambiguate overloaded identifiers. inferExpr propagated expect (App fun nargs rng) = inferApp propagated expect fun nargs rng From fcbdfdbe545556438d42cdc81811bc0a7e9f516f Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 26 May 2023 07:13:53 -0700 Subject: [PATCH 187/233] fix context path to go all the way to the final object --- kklib/ide/vs2022/kklib-test-interactive.vcxproj | 4 ---- kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters | 4 ---- src/Core/AnalysisCCtx.hs | 7 ++++--- 3 files changed, 4 insertions(+), 11 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index e96e841d9..ab10762b6 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,13 +165,9 @@ - - - - diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index 0b9ede722..55bde7b20 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -5,10 +5,6 @@ - - - - diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index 60f69a430..4f8a5ee81 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -105,9 +105,10 @@ cctxConFinal conName conRepr targs pre hole post = do mapM_ cctxCheckNoHole (pre ++ post) fname <- getFieldName conName (length pre + 1) let holetp = typeOf hole - (d1,var) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) - (d2,addr) <- makeUniqueDef (makeFieldAddrOf var conName fname holetp) - return (Ctx [d1,d2] var (Hole addr holetp)) + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) + (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName fname holetp) + (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) + return (Ctx [d1,d2,d3] var3 (Hole addr holetp)) cctxCheckNoHole :: Expr -> CCtx () cctxCheckNoHole expr From b7cc4be6c1bdbeddf3101ce62a824249b364cffc Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 26 May 2023 07:29:53 -0700 Subject: [PATCH 188/233] change context copy to copy up to holeptr (instead of a hole value) --- kklib/include/kklib.h | 2 +- kklib/src/refcount.c | 12 +++++++----- lib/std/core/types.kk | 2 +- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index b8f110072..e4760444f 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1307,7 +1307,7 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) #else // functional context application by copying along the context path and attaching `child` at the hole. -kk_decl_export kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t child, kk_context_t* ctx); +kk_decl_export kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t* holeptr, kk_box_t child, kk_context_t* ctx); // set the context path. // update the field_idx with the field index + 1 that is along the context path, and return `d` as is. diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index e4b51bfeb..a1f1910cd 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -719,11 +719,12 @@ static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { #endif #if !defined(KK_CCTX_NO_CONTEXT_PATH) -kk_decl_export kk_decl_noinline kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t child, kk_context_t* ctx) { +kk_decl_export kk_decl_noinline kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t* holeptr, kk_box_t child, kk_context_t* ctx) { kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res, ctx))); kk_box_t cres = kk_box_null(); // copied result context - kk_box_t* next = NULL; // pointer to the context path field in the parent block - for( kk_box_t cur = res; kk_box_is_ptr(cur); cur = *next ) { + kk_box_t* next = NULL; // pointer to the context path field in the (copied) parent block + for( kk_box_t cur = res; true; cur = *next ) { + kk_assert_internal(kk_box_is_ptr(cur)); kk_block_t* b = kk_ptr_unbox(cur, ctx); const kk_ssize_t field = kk_block_field_idx(b) - 1; kk_assert_internal(field >= 0); @@ -734,9 +735,10 @@ kk_decl_export kk_decl_noinline kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_bo else { kk_box_drop(*next,ctx); *next = kk_ptr_box(c, ctx); - } + } next = kk_block_field_address(c,field); - } + if (kk_block_field_address(b, field) == holeptr) break; + }; kk_assert_internal(next != NULL); *next = child; kk_box_drop(res,ctx); diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index e2128b462..5f80a5df8 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -378,7 +378,7 @@ pub value type field-addr // First-class constructor context (for _tail recursion module cons_ (TRMC) optimization). abstract value type cctxx - ".Cctx"( res : a, holeptr : field-addr ) + con ".Cctx"( res : a, holeptr : field-addr ) // First-class constructor context. pub alias cctx = cctxx From fa8f2e8a67f9fde6ceae89eeb9387022a208df42 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 26 May 2023 11:37:13 -0700 Subject: [PATCH 189/233] initial implementation of context composition --- lib/std/core/types.kk | 6 +++- src/Backend/C/FromCore.hs | 6 +++- src/Common/NamePrim.hs | 8 +++-- src/Compiler/Module.hs | 4 +-- src/Core/AnalysisCCtx.hs | 76 ++++++++++++++++++++++++++++----------- src/Core/CTail.hs | 1 + src/Core/Simplify.hs | 6 +++- src/Syntax/Parse.hs | 19 +++++++--- src/Syntax/Syntax.hs | 9 +++++ src/Type/Assumption.hs | 6 +++- src/Type/Infer.hs | 41 +++++++++++++++------ src/Type/InferMonad.hs | 31 +++++++++++++--- 12 files changed, 165 insertions(+), 48 deletions(-) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 5f80a5df8..e48a75f9f 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -395,9 +395,13 @@ pub extern ".cctx-create"( x : a, xhole : field-addr ) : cctxx // _Internal_. Extend a constructor context with a non-empty context pub inline extern ".cctx-extend"( c : cctxx, x : b, xhole : field-addr ) : cctxx - c inline "kk_cctx_apply(#1,#2,#3,false /*is-linear*/,kk_context())" + c inline "kk_cctx_extend(#1,#2,#3,false /*is-linear*/,kk_context())" js "_cctx_extend" +// _Internal_. Compose a constructor context with a non-empty context +pub inline extern ".cctx-compose-extend"( c1 : cctxx, c2 : cctxx ) : cctxx + c inline "kk_cctx_extend(#1,#2.res,#2.holeptr,false /*is-linear*/,kk_context())" + js "_cctx_compose" // Apply a constructor context pub inline extern []( c : cctxx, x : b ) : a diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 9059f20e5..d768dda11 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1091,7 +1091,11 @@ genDropNCall tp args = -- genDupDropCallX "dropn" tp (arguments args) genHoleCall :: Type -> Doc genHoleCall tp = -- ppType tp <.> text "_hole()") - text "kk_datatype_null()" + case cType tp of + CPrim "kk_integer_t" -> text "kk_integer_zero" + CPrim "kk_string_t" -> text "kk_string_empty()" + CPrim "kk_vector_t" -> text "kk_vector_empty()" + _ -> text "kk_datatype_null()" conBaseCastNameInfo :: ConInfo -> Doc diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index 68d3c5adf..695523d6f 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -78,6 +78,7 @@ module Common.NamePrim , nameCCtxApply , nameCCtxExtend , nameCCtxCompose + , nameCCtxComposeExtend , nameCCtxSetCtxPath , nameTpFieldAddr, nameFieldAddrOf @@ -300,10 +301,11 @@ nameTpCCtx = cfieldName "cctx" nameCCtxCreate = cfieldName ".cctx-create" nameCCtxHoleCreate= cfieldName ".cctx-hole-create" -nameCCtxEmpty = cfieldName ".cctx-empty" -nameCCtxApply = cfieldName ".cctx-apply" nameCCtxExtend = cfieldName ".cctx-extend" -nameCCtxCompose = cfieldName ".cctx-compose" +nameCCtxComposeExtend = cfieldName ".cctx-compose-extend" +nameCCtxEmpty = cfieldName "cctx-empty" +nameCCtxApply = cfieldName "cctx-apply" +nameCCtxCompose = cfieldName "cctx-compose" nameCCtxSetCtxPath= cfieldName ".cctx-setcp" nameTpFieldAddr = cfieldName "field-addr" diff --git a/src/Compiler/Module.hs b/src/Compiler/Module.hs index 3af52bf5c..1c1bd29f9 100644 --- a/src/Compiler/Module.hs +++ b/src/Compiler/Module.hs @@ -38,7 +38,7 @@ import Kind.Newtypes ( Newtypes, newtypesEmpty, newtypesCompose, extrac import Kind.Constructors ( Constructors, constructorsEmpty, constructorsCompose, extractConstructors ) import Kind.Assumption ( KGamma, kgammaInit, extractKGamma, kgammaUnion ) -import Type.Assumption ( Gamma, gammaInit, gammaUnion, extractGamma, gammaNames) +import Type.Assumption ( Gamma, gammaInit, gammaUnion, extractGamma, gammaNames, gammaPublicNames) import Type.Type ( DataInfo ) import Core.Inlines ( Inlines, inlinesNew, inlinesEmpty, inlinesExtends ) import Core.Borrowed ( Borrowed, borrowedEmpty, borrowedExtendICore ) @@ -125,7 +125,7 @@ loadedNames l loadedMatchNames :: Loaded -> [String] loadedMatchNames l - = map (showPlain . unqualify) $ filter (not . isHiddenName) (loadedNames l) + = map (showPlain . unqualify) $ gammaPublicNames (loadedGamma l) where -- good (c:_) = (c /= '.') diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index 4f8a5ee81..e0afe14e2 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -30,6 +30,7 @@ import Common.NamePrim(nameCCtxHoleCreate,nameCCtxCreate,nameCCtxEmpty,nameCCtxS import Common.Range import Common.Unique(HasUnique(..)) import Common.Failure +import Common.Syntax import Kind.Newtypes import Kind.Kind import Type.Type @@ -39,9 +40,14 @@ import Core.Core import Core.Pretty -- take a context and check if it is well-formed and return a well-typed context expression -analyzeCCtx :: Range -> Newtypes -> Expr -> Either [(Range,Doc)] Expr -analyzeCCtx rng newtypes expr - = runCCtx rng newtypes 0 (cctxCreate expr) +analyzeCCtx :: Range -> Newtypes -> Expr -> (Int -> ((Expr,[(Range,Doc)]),Int)) +analyzeCCtx rng newtypes expr uniq + = let (res,uniq') = runCCtx rng newtypes uniq (cctxCreate expr) + in case res of + Right e -> ((e,[]),uniq') + Left errs -> let errs' = if null errs then [(rng,text "ill-formed context")] + else errs + in ((makeCCtxEmpty (typeOf expr),errs'),uniq) data Hole = Hole{ holeAddr :: Expr, holeType :: Type } @@ -53,7 +59,7 @@ cctxCreate expr | isHole expr = do return (makeCCtxEmpty (typeOf expr)) -- non-empty context cctxCreate expr - = do mtrace ("expr: " ++ show expr) + = do -- mtrace ("expr: " ++ show expr) (Ctx defs top (Hole addr holetp)) <- cctxExpr expr let tp = typeOf top let cctx = makeCCtxCreate tp holetp top addr @@ -92,7 +98,8 @@ cctxCon conName conRepr targs args cctxConRecurse :: TName -> ConRepr -> [Type] -> [Expr] -> CCtx Ctx cctxConRecurse conName conRepr targs args - = do (pre,ctx,post) <- cctxFind [] args + = do -- mtrace "recurse" + (pre,ctx,post) <- cctxFind [] [] args mapM_ cctxCheckNoHole (pre ++ post) (ds,vars) <- unzip <$> mapM makeUniqueDef pre (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (vars ++ [top ctx] ++ post)) @@ -102,9 +109,11 @@ cctxConRecurse conName conRepr targs args cctxConFinal :: TName -> ConRepr -> [Type] -> [Expr] -> Expr -> [Expr] -> CCtx Ctx cctxConFinal conName conRepr targs pre hole post - = do mapM_ cctxCheckNoHole (pre ++ post) + = do -- mtrace "final" + mapM_ cctxCheckNoHole (pre ++ post) fname <- getFieldName conName (length pre + 1) let holetp = typeOf hole + ensureValidHoleType holetp (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName fname holetp) (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) @@ -112,18 +121,19 @@ cctxConFinal conName conRepr targs pre hole post cctxCheckNoHole :: Expr -> CCtx () cctxCheckNoHole expr - = -- todo: check no holes in expr + = -- note: not needed as it as already checked during type inference return () -cctxFind :: [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) +cctxFind :: [(Range,Doc)] -> [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) -- no args -cctxFind acc [] = illegal +cctxFind errs acc [] + = emitErrors errs -- try recursively -cctxFind acc (arg:args) +cctxFind errs acc (arg:args) = do r <- try (cctxExpr arg) case r of - Left _ -> cctxFind (arg:acc) args + Left errs' -> cctxFind (errs ++ errs') (arg:acc) args Right ctx -> return (reverse acc,ctx,args) @@ -193,11 +203,11 @@ makeCCtxSetContextPath obj conName fieldName newtype CCtx a = CCtx (Int -> CCtxEnv -> Result a) -runCCtx :: Range -> Newtypes -> Int -> CCtx a -> Either [(Range,Doc)] a +runCCtx :: Range -> Newtypes -> Int -> CCtx a -> (Either [(Range,Doc)] a,Int) runCCtx rng nt uniq (CCtx c) = case (c uniq (CCtxEnv rng nt)) of - Ok x u' -> Right x - Err errs -> Left errs + Ok x u' -> (Right x,u') + Err errs -> (Left errs,uniq) @@ -238,10 +248,15 @@ updateEnv :: (CCtxEnv -> CCtxEnv) -> CCtx a -> CCtx a updateEnv f (CCtx c) = CCtx (\u env -> c u (f env)) -emitErrors :: [Doc] -> CCtx a +emitError :: Doc -> CCtx a +emitError doc + = do env <- getEnv + emitErrors [(rng env,doc)] + +emitErrors :: [(Range,Doc)] -> CCtx a emitErrors errs - = do env <- getEnv - CCtx (\u env -> Err [(rng env,d) | d <- errs]) + = do -- mtrace ("emit errors: " ++ show errs) + (CCtx (\u env -> Err errs)) try :: CCtx a -> CCtx (Either [(Range,Doc)] a) @@ -264,6 +279,26 @@ getFieldName cname fieldIdx Left err -> failure ("Core.AnalysisCCtx: " ++ err) Right name -> return name +ensureValidHoleType :: Type -> CCtx () +ensureValidHoleType tp + = do env <- getEnv + case dataTypeNameOf tp of + Left (TVar{}) -> emitError (text "the hole in the constructor context has an unresolved or polymorphic type") + Left _ -> emitError (text "the hole in the constructor context has an invalid data type") + Right name -> case newtypesLookupAny name (newtypes env) of + Just dataInfo -> + do let (dataRepr,_) = getDataRepr dataInfo + when (dataDefIsValue (dataInfoDef dataInfo) || dataReprIsValue dataRepr) $ + emitError (text "the hole in a constructor context cannot be a value type") + return () + +dataTypeNameOf :: Type -> Either Type Name +dataTypeNameOf tp = case expandSyn tp of + TApp t ts -> dataTypeNameOf t + TCon tc -> Right (typeConName tc) + t -> Left t + + lookupFieldName :: TName -> Int -> CCtx (Either String Name) lookupFieldName cname field = do env <- getEnv @@ -282,7 +317,6 @@ lookupFieldName cname field getDataTypeName cname = case splitFunScheme (typeOf cname) of Just (_,_,_,_,tres) -> getDataTypeNameRes tres Nothing -> failure $ "Core.CTail.getFieldName: illegal constructor type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) - getDataTypeNameRes tp = case expandSyn tp of - TApp t ts -> getDataTypeNameRes t - TCon tc -> typeConName tc - _ -> failure $ "Core.CTail.getFieldName: illegal result type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) + getDataTypeNameRes tp = case dataTypeNameOf tp of + Right name -> name + _ -> failure $ "Core.CTail.getFieldName: illegal result type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index daa90c94a..1c59109aa 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -470,6 +470,7 @@ makeCCtxExtend slot resName objName conName fieldName tp alwaysAffine a = TypeVar 0 kindStar Bound + -- Apply a context to its final value. makeCCtxApply :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr makeCCtxApply True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index 61c16d9bf..d29cb6e8f 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -22,7 +22,7 @@ import Common.Syntax import Common.NamePrim( nameEffectOpen, nameToAny, nameReturn, nameOptionalNone, nameIsValidK , nameLift, nameBind, nameEvvIndex, nameClauseTailNoYield, isClauseTailName , nameBox, nameUnbox, nameAssert - , nameAnd, nameOr, isNameTuple ) + , nameAnd, nameOr, isNameTuple, nameCCtxComposeExtend, nameCCtxEmpty ) import Common.Unique import Type.Type import Type.Kind @@ -349,6 +349,10 @@ bottomUp (App (Lam pars eff body) args) | length pars == length args && all fre bottomUp (App (TypeApp (Var bind _) _) [App (TypeApp (Var lift _) _) [arg], cont]) | getName bind == nameBind && getName lift == nameLift = App cont [arg] +-- c[ctx hole] -> c +bottomUp (App (TypeApp (Var cextend _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName cextend == nameCCtxComposeExtend && getName cempty == nameCCtxEmpty + = ctx1 + -- continuation validation bottomUp expr@(App (TypeApp (Var isValidK _) _) [arg]) | getName isValidK == nameIsValidK = case arg of diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 9b1c2782c..f44d1561d 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -1899,9 +1899,16 @@ appexpr allowTrailingLam indexer = do rng0 <- lidx - idxs <- sepBy1 expr comma - rng1 <- special "]" - return (\exp -> App (Var nameIndex False (combineRange rng0 rng1)) (map (\a -> (Nothing,a)) (exp:idxs)) (combineRange rng0 rng1)) + (do crng <- keyword "ctx" + ctx <- ccontext crng + rng1 <- special "]" + return (\exp -> let rng = combineRanged exp rng1 + in App (Var nameCCtxComposeExtend False rng) [(Nothing,exp),(Nothing,ctx)] rng) + <|> + do idxs <- sepBy1 expr comma + rng1 <- special "]" + return (\exp -> App (Var nameIndex False (combineRange rng0 rng1)) (map (\a -> (Nothing,a)) (exp:idxs)) (combineRange rng0 rng1)) + ) applier = do rng0 <- lapp @@ -2010,7 +2017,11 @@ makeCons rng x xs = makeApp (Var nameCons False rng) [x,xs] cctxExpr :: LexParser UserExpr cctxExpr = do rng <- keyword "ctx" - ctx <- ntlexpr + ccontext rng + +ccontext :: Range -> LexParser UserExpr +ccontext rng + = do ctx <- ntlexpr return (makeApp (Var nameCCtxCreate False rng) [ctx]) cctxHole :: LexParser UserExpr diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index 35fb99af3..f7e8fc1d6 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -284,6 +284,15 @@ data Lit | LitString String Range deriving (Show) + +stripExpr :: Expr t -> Expr t +stripExpr (Parens e _ _) = stripExpr e +stripExpr (Ann e _ _) = stripExpr e +stripExpr e = e + + + + {-------------------------------------------------------------------------- types and Kinds --------------------------------------------------------------------------} diff --git a/src/Type/Assumption.hs b/src/Type/Assumption.hs index 615eec141..ec786fefb 100644 --- a/src/Type/Assumption.hs +++ b/src/Type/Assumption.hs @@ -18,7 +18,7 @@ module Type.Assumption ( , gammaMap , gammaList , gammaIsEmpty - , gammaNames + , gammaNames, gammaPublicNames , ppGamma, ppGammaHidden, gammaRemove, gammaUnion, gammaUnions , gammaFilter , isInfoCon @@ -247,6 +247,10 @@ gammaNames :: Gamma -> [Name] gammaNames (Gamma g) = M.keys g +gammaPublicNames :: Gamma -> [Name] +gammaPublicNames (Gamma g) + = [name | (name,ninfos) <- M.toList g, all (infoIsVisible . snd) ninfos && not (isHiddenName name)] + {--------------------------------------------------------------- Extract from core ---------------------------------------------------------------} diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index 7b2c9f514..e0a40b929 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -39,7 +39,7 @@ import Common.NamePrim( nameTpOptional, nameOptional, nameOptionalNone, nameCopy , nameTpValueOp, nameClause, nameIdentity , nameMaskAt, nameMaskBuiltin, nameEvvIndex, nameHTag, nameTpHTag , nameInt32, nameOr, nameAnd, nameEffectOpen - , nameCCtxCreate + , nameCCtxCreate, nameCCtxHoleCreate ) import Common.Range import Common.Unique @@ -446,7 +446,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl if (verbose penv >= 3) then Lib.Trace.trace ("infer: " ++ show sort ++ " " ++ show name) $ return () else return () - withDefName name $ + withDefName name $ disallowHole $ (if (not (isDefFun sort) || nameIsNil name) then id else allowReturn True) $ do (tp,eff,coreExpr) <- inferExpr Nothing expect expr -- Just annTp -> inferExpr (Just (annTp,rng)) (if (isRho annTp) then Instantiated else Generalized) (Ann expr annTp rng) @@ -463,7 +463,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl inferBindDef :: Def Type -> Inf (Effect,Core.Def) inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc) = -- trace ("infer bind def: " ++ show name ++ ", var?:" ++ show (sort==DefVar)) $ - do withDefName name $ + do withDefName name $ disallowHole $ do (tp,eff,coreExpr) <- inferExpr Nothing Instantiated expr stp <- subst tp -- Just annTp -> inferExpr (Just (annTp,rng)) Instantiated (Ann expr annTp rng) @@ -534,6 +534,7 @@ inferIsolated contextRange range body inf inferExpr :: Maybe (Type,Range) -> Expect -> Expr Type -> Inf (Type,Effect,Core.Expr) inferExpr propagated expect (Lam binders body rng) = isNamedLam $ \isNamed -> + disallowHole $ do -- traceDoc $ \env -> text " inferExpr.Lam:" <+> pretty (show expect) <+> text ", propagated:" <+> ppProp env propagated (propArgs,propEff,propBody,skolems,expectBody) <- matchFun (length binders) propagated @@ -711,14 +712,33 @@ inferExpr propagated expect (App (h@Handler{hndlrAllowMask=Nothing}) [action] rn inferExpr propagated expect (App (Var byref _ _) [(_,Var name _ rng)] _) | byref == nameByref = inferVar propagated expect name rng False +-- | Hole expressions +inferExpr propagated expect (App fun@(Var hname _ _) [] rng) | hname == nameCCtxHoleCreate + = do ok <- useHole + when (not ok) $ + contextError rng rng (text "ill-formed constructor context") + [(text "because",text "there can be only one hole, and it must occur under a constructor context 'ctx'")] + inferApp propagated expect fun [] rng + -- | Context expressions inferExpr propagated expect (App (Var ctxname _ nameRng) [(_,expr)] rng) | ctxname == nameCCtxCreate - = do (tp,eff,core) <- inferExpr Nothing -- todo: propagate through cctx - Instantiated expr + = do tpv <- Op.freshTVar kindStar Meta + holetp <- Op.freshTVar kindStar Meta + let ctxTp = TApp typeCCtxx [tpv,holetp] + prop <- case propagated of + Nothing -> return Nothing + Just (ctp,crng) -> do inferUnify (checkMatch crng) nameRng ctp ctxTp + stp <- subst tpv + return (Just (stp,rng)) + ((tp,eff,core),hole) <- allowHole $ inferExpr prop Instantiated expr + inferUnify (Infer rng) nameRng tp tpv + when (not hole) $ + contextError rng rng (text "ill-formed constructor context") [(text "because",text "the context has no 'hole'")] newtypes <- getNewtypes - case analyzeCCtx rng newtypes core of - Left errs -> failure ("Type.Infer.context") - Right ccore -> return (Core.typeOf ccore,eff,ccore) + score <- subst core + (ccore,errs) <- withUnique (analyzeCCtx rng newtypes score) + mapM_ (\(rng,err) -> infError rng err) errs + return (Core.typeOf ccore,eff,ccore) -- | Application nodes. Inference is complicated here since we need to disambiguate overloaded identifiers. inferExpr propagated expect (App fun nargs rng) @@ -778,9 +798,10 @@ inferExpr propagated expect (Handler handlerSort scoped HandlerOverride mbAllowM inferExpr propagated expect (Case expr branches rng) = -- trace " inferExpr.Case" $ - do (ctp,ceff,ccore) <- allowReturn False $ inferExpr Nothing Instantiated expr + do (ctp,ceff,ccore) <- allowReturn False $ disallowHole $ inferExpr Nothing Instantiated expr -- infer branches - bress <- case (propagated,branches) of + bress <- disallowHole $ + case (propagated,branches) of (Nothing,(b:bs)) -> -- propagate the type of the first branch do bres@(tpeffs,_) <- inferBranch propagated ctp (getRange expr) b let tp = case tpeffs of diff --git a/src/Type/InferMonad.hs b/src/Type/InferMonad.hs index 2ad88aaa3..ca27633df 100644 --- a/src/Type/InferMonad.hs +++ b/src/Type/InferMonad.hs @@ -39,6 +39,7 @@ module Type.InferMonad( Inf, InfGamma -- * Misc. , allowReturn, isReturnAllowed + , useHole, allowHole, disallowHole , withLhs, isLhs , getPrettyEnv , splitEffect @@ -840,15 +841,16 @@ data Env = Env{ prettyEnv :: !Pretty.Env , gamma :: !Gamma , infgamma :: !InfGamma , imports :: !ImportMap - , returnAllowed :: Bool - , inLhs :: Bool + , returnAllowed :: !Bool + , inLhs :: !Bool } -data St = St{ uniq :: !Int, sub :: !Sub, preds :: ![Evidence], mbRangeMap :: Maybe RangeMap } +data St = St{ uniq :: !Int, sub :: !Sub, preds :: ![Evidence], holeAllowed :: !Bool, mbRangeMap :: Maybe RangeMap } runInfer :: Pretty.Env -> Maybe RangeMap -> Synonyms -> Newtypes -> ImportMap -> Gamma -> Name -> Int -> Inf a -> Error (a,Int,Maybe RangeMap) runInfer env mbrm syns newTypes imports assumption context unique (Inf f) - = case f (Env env context (newName "") False newTypes syns assumption infgammaEmpty imports False False) (St unique subNull [] mbrm) of + = case f (Env env context (newName "") False newTypes syns assumption infgammaEmpty imports False False) + (St unique subNull [] False mbrm) of Err err warnings -> addWarnings warnings (errorMsg (ErrorType [err])) Ok x st warnings -> addWarnings warnings (ok (x, uniq st, (sub st) |-> mbRangeMap st)) @@ -953,6 +955,27 @@ isReturnAllowed = do env <- getEnv return (returnAllowed env) +useHole :: Inf Bool +useHole + = do st0 <- updateSt (\st -> st{ holeAllowed = False } ) + return (holeAllowed st0) + +disallowHole :: Inf a -> Inf a +disallowHole action + = do st0 <- updateSt(\st -> st{ holeAllowed = False }) + let prev = holeAllowed st0 + x <- action + updateSt(\st -> st{ holeAllowed = prev }) + return x + +allowHole :: Inf a -> Inf (a,Bool {- was the hole used? -}) +allowHole action + = do st0 <- updateSt(\st -> st{ holeAllowed = True }) + let prev = holeAllowed st0 + x <- action + st1 <- updateSt(\st -> st{ holeAllowed = prev }) + return (x,not (holeAllowed st1)) + getSub :: Inf Sub From 8c707eefcef6fea8a29c41f96a8fd601d5670d50 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 26 May 2023 12:00:28 -0700 Subject: [PATCH 190/233] add ctx/hole keywords to vscode --- support/vscode/koka.language-koka/syntaxes/koka.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/support/vscode/koka.language-koka/syntaxes/koka.json b/support/vscode/koka.language-koka/syntaxes/koka.json index 327c8611e..53a719f2e 100644 --- a/support/vscode/koka.language-koka/syntaxes/koka.json +++ b/support/vscode/koka.language-koka/syntaxes/koka.json @@ -305,7 +305,7 @@ }, "reservedid" : - { "match": "(return(?=(?:\\(|\\s+\\(?)\\w[\\w\\-]*\\s*(?:\\)\\s*(?:[^;])))|infix|infixr|infixl|type|co|rec|struct|alias|forall|exists|some|extern|fun|fn|val|var|con|with(?:\\s+override)?|module|import|as|in|pub|abstract|effect|named|(?:raw\\s+|final\\s+)ctl|break|continue|unsafe|mask(?:\\s+behind)?|handle|handler)(?![\\w\\-?'])" + { "match": "(return(?=(?:\\(|\\s+\\(?)\\w[\\w\\-]*\\s*(?:\\)\\s*(?:[^;])))|infix|infixr|infixl|type|co|rec|struct|alias|forall|exists|some|extern|fun|fn|val|var|con|with(?:\\s+override)?|module|import|as|in|ctx|hole|pub|abstract|effect|named|(?:raw\\s+|final\\s+)ctl|break|continue|unsafe|mask(?:\\s+behind)?|handle|handler)(?![\\w\\-?'])" , "name": "keyword.other koka.keyword" }, From ee10c3707c5d308ed9ad71b018f9b2e78f4a5252 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 26 May 2023 17:21:55 -0700 Subject: [PATCH 191/233] improve constructor contexts --- lib/std/core.kk | 1 - lib/std/core/types.kk | 25 +++++++++++++------------ src/Common/NamePrim.hs | 10 ++++++---- src/Core/AnalysisCCtx.hs | 10 ++++++++-- src/Core/Simplify.hs | 14 ++++++++++++-- src/Syntax/Parse.hs | 12 ++++++++---- 6 files changed, 47 insertions(+), 25 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index 4c20119c9..9417a976e 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -20,7 +20,6 @@ pub import std/core/hnd pub infixr 80 (^) pub infixl 70 (*), (%), (/), cdiv, cmod -pub infixr 60 (++) pub infixl 60 (+), (-) pub infix 40 (!=), (==), (<=), (>=), (<), (>) // prefix (!), (-) diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index e48a75f9f..042307838 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -15,6 +15,7 @@ */ module std/core/types +pub infixr 60 (++) pub infixr 30 (&&) pub infixr 20 (||) @@ -367,7 +368,7 @@ pub value type optional // _tail recursion module cons_ (TRMC) optimization. // ---------------------------------------------------------------------------- -extern import +extern import c header-end-file "types-cctx-inline.h" js file "types-cctx-inline.js" @@ -377,44 +378,44 @@ extern import pub value type field-addr // First-class constructor context (for _tail recursion module cons_ (TRMC) optimization). -abstract value type cctxx +abstract value type cctx con ".Cctx"( res : a, holeptr : field-addr ) // First-class constructor context. -pub alias cctx = cctxx +pub alias ctx = cctx // _Internal_. Create a hole for a context -pub inline extern ".cctx-hole-create"() : e a +pub extern ".cctx-hole-create"() : a c inline "kk_intf_box(0)" js inline "undefined" // _Internal_. Create an initial non-empty context. -pub extern ".cctx-create"( x : a, xhole : field-addr ) : cctxx +pub extern ".cctx-create"( x : a, xhole : field-addr ) : cctx c "kk_cctx_create" js "_cctx_create" // _Internal_. Extend a constructor context with a non-empty context -pub inline extern ".cctx-extend"( c : cctxx, x : b, xhole : field-addr ) : cctxx +pub inline extern ".cctx-extend"( c : cctx, x : b, xhole : field-addr ) : cctx c inline "kk_cctx_extend(#1,#2,#3,false /*is-linear*/,kk_context())" js "_cctx_extend" // _Internal_. Compose a constructor context with a non-empty context -pub inline extern ".cctx-compose-extend"( c1 : cctxx, c2 : cctxx ) : cctxx +pub inline extern ".cctx-compose-extend"( c1 : cctx, c2 : cctx ) : cctx c inline "kk_cctx_extend(#1,#2.res,#2.holeptr,false /*is-linear*/,kk_context())" js "_cctx_compose" // Apply a constructor context -pub inline extern []( c : cctxx, x : b ) : a +pub inline extern []( c : cctx, x : b ) : a c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" js "_cctx_apply" // Compose two constructor contexts. -pub inline extern cctx-compose( c1 : cctxx, c2 : cctxx ) : cctxx - c inline "kk_cctx_compose(#1,#2,false /*is-linear*/,kk_context())" - js "_cctx_compose" +pub inline extern (++)( c1 : cctx, c2 : cctx ) : cctx + c inline "kk_cctx_compose(#1,#2,false /* is-linear */,kk_context())" + js "_cctx_compose" // Create an empty context -pub inline extern cctx-empty() : cctxx +pub inline extern cctx-empty() : cctx c "kk_cctx_empty" js "_cctx_empty" diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index 695523d6f..392dabcde 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -296,18 +296,20 @@ nameCTailSetCtxPath=cfieldName ".ctail-set-context-path" cfieldName name = coreTypesName name -nameTpCCtxx = cfieldName "cctxx" -nameTpCCtx = cfieldName "cctx" +nameTpCCtxx = cfieldName "cctx" +nameTpCCtx = cfieldName "ctx" nameCCtxCreate = cfieldName ".cctx-create" nameCCtxHoleCreate= cfieldName ".cctx-hole-create" nameCCtxExtend = cfieldName ".cctx-extend" nameCCtxComposeExtend = cfieldName ".cctx-compose-extend" nameCCtxEmpty = cfieldName "cctx-empty" -nameCCtxApply = cfieldName "cctx-apply" -nameCCtxCompose = cfieldName "cctx-compose" nameCCtxSetCtxPath= cfieldName ".cctx-setcp" +nameCCtxApply = cfieldName "([])" +nameCCtxCompose = cfieldName "(++)" + + nameTpFieldAddr = cfieldName "field-addr" nameFieldAddrOf = cfieldName ".field-addr-of" diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index e0afe14e2..7b9699a79 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -26,7 +26,9 @@ import Lib.PPrint import Common.Syntax( Target(..), JsTarget(..), CTarget(..) ) import Common.Id import Common.Name -import Common.NamePrim(nameCCtxHoleCreate,nameCCtxCreate,nameCCtxEmpty,nameCCtxSetCtxPath,nameFieldAddrOf,nameTpFieldAddr) +import Common.NamePrim(nameCCtxHoleCreate,nameCCtxCreate,nameCCtxEmpty,nameCCtxSetCtxPath, + nameFieldAddrOf,nameTpFieldAddr, + nameEffectOpen) import Common.Range import Common.Unique(HasUnique(..)) import Common.Failure @@ -75,6 +77,8 @@ cctxExpr expr App (TypeApp (con@(Con name repr)) targs) args | not (null args) -> cctxCon name repr targs args + + -- App (App (TypeApp (Var open _) [effFrom,effTo,tpFrom,tpTo]) [f]) []) | getName open == nameEffectOpen _ -> illegal @@ -116,7 +120,7 @@ cctxConFinal conName conRepr targs pre hole post ensureValidHoleType holetp (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName fname holetp) - (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) + (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) -- should be last as it consumes var1 return (Ctx [d1,d2,d3] var3 (Hole addr holetp)) cctxCheckNoHole :: Expr -> CCtx () @@ -147,6 +151,8 @@ makeUniqueDef expr isHole :: Expr -> Bool isHole (App (TypeApp (Var (TName hname htp) _) [tp,_etp]) []) = (hname == nameCCtxHoleCreate) +isHole (App (App (TypeApp (Var open _) [effFrom,effTo,tpFrom,tpTo]) [TypeApp (Var hname _) _]) []) + = (getName open == nameEffectOpen) && (getName hname == nameCCtxHoleCreate) isHole _ = False -- Initial empty context (ctx hole) diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index d29cb6e8f..73639883c 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -22,7 +22,9 @@ import Common.Syntax import Common.NamePrim( nameEffectOpen, nameToAny, nameReturn, nameOptionalNone, nameIsValidK , nameLift, nameBind, nameEvvIndex, nameClauseTailNoYield, isClauseTailName , nameBox, nameUnbox, nameAssert - , nameAnd, nameOr, isNameTuple, nameCCtxComposeExtend, nameCCtxEmpty ) + , nameAnd, nameOr, isNameTuple + , nameCCtxCompose, nameCCtxComposeExtend, nameCCtxEmpty ) + import Common.Unique import Type.Type import Type.Kind @@ -349,10 +351,18 @@ bottomUp (App (Lam pars eff body) args) | length pars == length args && all fre bottomUp (App (TypeApp (Var bind _) _) [App (TypeApp (Var lift _) _) [arg], cont]) | getName bind == nameBind && getName lift == nameLift = App cont [arg] --- c[ctx hole] -> c +-- composition extension: c[ctx hole] -> c bottomUp (App (TypeApp (Var cextend _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName cextend == nameCCtxComposeExtend && getName cempty == nameCCtxEmpty = ctx1 +-- context composition: c ++ ctx _ == c == ctx _ ++ c +bottomUp (App (TypeApp (Var ctxcomp _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName ctxcomp == nameCCtxCompose && getName cempty == nameCCtxEmpty + = ctx1 + +bottomUp (App (TypeApp (Var ctxcomp _) _) [App (TypeApp (Var cempty _) _) [],ctx2]) | getName ctxcomp == nameCCtxCompose && getName cempty == nameCCtxEmpty + = ctx2 + + -- continuation validation bottomUp expr@(App (TypeApp (Var isValidK _) _) [arg]) | getName isValidK == nameIsValidK = case arg of diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index f44d1561d..e2fb7b663 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -2026,7 +2026,7 @@ ccontext rng cctxHole :: LexParser UserExpr cctxHole - = do rng <- keyword "hole" + = do rng <- keyword "hole" <|> do { (_,r) <- wildcard; return r } return (makeApp (Var nameCCtxHoleCreate False rng) []) @@ -2367,7 +2367,7 @@ anntypek return tp) tid - = do (id,rng) <- qvarid + = do (id,rng) <- qvarid <|> typeidCtx return (if isTypeVar id then TpVar id rng else TpCon id rng) <|> do (id,rng) <- wildcard "" @@ -2702,17 +2702,21 @@ ensureUnqualified entity p ----------------------------------------------------------- -- Lexical tokens ----------------------------------------------------------- -qtypeid :: LexParser (Name,Range) +qtypeid, typeidCtx :: LexParser (Name,Range) qtypeid = try $ do pos <- getPosition - (name,range) <- qvarid + (name,range) <- qvarid <|> typeidCtx if (not (isTypeVar name)) then return (name,range) else -- trace ("not a qtype: " ++ show name) $ do setPosition pos mzero "type name (and not type variable)" +typeidCtx + = do r <- keyword "ctx" + return (newName "ctx",r) + qop :: LexParser (Name,Range) qop = do (Lexeme rng (LexOp id)) <- parseLex (LexOp nameNil) From 299009f9ab7b9bd0285329085a263ebce62c2652 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 09:45:07 -0700 Subject: [PATCH 192/233] updates for artificat --- lib/std/core.kk | 1 - lib/std/core/types-cctx-inline.h | 82 +++++++++++++++++++++ lib/std/core/types-cctx-inline.js | 43 +++++++++++ src/Core/Simplify.hs | 1 + test/fip/bench.sh | 39 ++++++---- test/fip/src/{finger => ftree}/ftree-fip.kk | 0 test/fip/src/{finger => ftree}/ftree-std.kk | 0 test/fip/src/msort/msort-fip.kk | 20 ++--- test/fip/src/qsort/qsort-fip.kk | 12 +-- 9 files changed, 167 insertions(+), 31 deletions(-) create mode 100644 lib/std/core/types-cctx-inline.h create mode 100644 lib/std/core/types-cctx-inline.js rename test/fip/src/{finger => ftree}/ftree-fip.kk (100%) rename test/fip/src/{finger => ftree}/ftree-std.kk (100%) diff --git a/lib/std/core.kk b/lib/std/core.kk index 9417a976e..94c96105b 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1085,7 +1085,6 @@ pub inline fip fun i32( i : int ) : int32 i.int32 - // Minimal set of operations that we need in `std/core`. inline fip extern (<=) : (int32,int32) -> bool inline "(#1 <= #2)" diff --git a/lib/std/core/types-cctx-inline.h b/lib/std/core/types-cctx-inline.h new file mode 100644 index 000000000..69c353512 --- /dev/null +++ b/lib/std/core/types-cctx-inline.h @@ -0,0 +1,82 @@ + + + + + + +/*--------------------------------------------------------------------------- + Copyright 2020-2023, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +static inline kk_box_t kk_cctx_hole(void) { + return kk_intf_box(0); // for now, this must be a value; see `kklib/src/refcount.c:kk_cctx_copy_apply` +} + +static inline kk_std_core_types__cctx kk_cctx_empty(kk_context_t* ctx) { + return kk_std_core_types__new_Cctx( kk_cctx_hole(), NULL, ctx); +} + +static inline kk_std_core_types__cctx kk_cctx_create( kk_box_t res, kk_box_t* field, kk_context_t* ctx) { + return kk_std_core_types__new_Cctx( res, field, ctx); +} + + +static inline kk_box_t kk_cctx_apply_linear( kk_std_core_types__cctx acc, kk_box_t child ) { + #if 1 + if (kk_likely(acc.holeptr != NULL)) { + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,kk_get_context()))); + *(acc.holeptr) = child; + return acc.res; + } + else { + return child; + } + #else + // this form entices conditional moves (but seems slower in general) + if (acc.holeptr != NULL) { *acc.holeptr = child; } + return (acc.holeptr != NULL ? acc.res : child); + #endif +} + +static inline kk_box_t kk_cctx_apply_nonlinear( kk_std_core_types__cctx acc, kk_box_t child, kk_context_t* ctx ) { + // note: written like this for best codegen; be careful when rewriting. + if (acc.holeptr != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))) { // no kk_likely seem slightly better + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); + *(acc.holeptr) = child; // in-place update the hole with the child + return acc.res; + } + else if (kk_likely(acc.holeptr == NULL)) { + return child; + } + else { + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); + return kk_cctx_copy_apply(acc.res,acc.holeptr,child,ctx); // copy the context path to the hole and compose with the child + } +} + +// apply a context to a child value +// is_linear is always a constant and set to `true` if the effect is guaranteed linear +static inline kk_box_t kk_cctx_apply( kk_std_core_types__cctx acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { + #if defined(KK_CCTX_NO_CONTEXT_PATH) + return kk_cctx_apply_linear(acc,child); // compiler generates the right code for the non-linear case + #else + if (is_linear) return kk_cctx_apply_linear(acc,child); + else return kk_cctx_apply_nonlinear(acc,child,ctx); + #endif +} + +// extend a context with a non-empty context +static inline kk_std_core_types__cctx kk_cctx_extend( kk_std_core_types__cctx acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { + return kk_std_core_types__new_Cctx( kk_cctx_apply(acc,child,is_linear,ctx), field, ctx ); +} + +// compose a context +static inline kk_std_core_types__cctx kk_cctx_compose( kk_std_core_types__cctx acc1, kk_std_core_types__cctx acc2, bool is_linear, kk_context_t* ctx ) { + if (acc2.holeptr == NULL) return acc1; + return kk_cctx_extend(acc1,acc2.res,acc2.holeptr,is_linear,ctx); +} + diff --git a/lib/std/core/types-cctx-inline.js b/lib/std/core/types-cctx-inline.js new file mode 100644 index 000000000..8635715d0 --- /dev/null +++ b/lib/std/core/types-cctx-inline.js @@ -0,0 +1,43 @@ +/*--------------------------------------------------------------------------- + Copyright 2012-2023, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ +export function _cctx_empty() { + return _Cctx(undefined,{obj:undefined,field_name:""}) +} + +export function _cctx_create(res,field_addr) { + return _Cctx(res,field_addr); +} + +export function _cctx_extend(acc,res,field_addr) { + if (acc.res===undefined) { + return _Cctx(res,field_addr); + } + else { + acc.holeptr.obj[acc.holeptr.field_name] = res; + return _Cctx(acc.res,field_addr); + } +} + +export function _cctx_compose(ctx1,ctx2) { + if (ctx2.res==undefined) { + return ctx1; + } + else { + return _cctx_extend(ctx1,ctx2.res,ctx2.field_addr); + } +} + +export function _cctx_apply(acc,res) { + if (acc.res===undefined) { + return res; + } + else { + acc.holeptr.obj[acc.holeptr.field_name] = res; + return acc.res; + } +} diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index 73639883c..9767f69f4 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -351,6 +351,7 @@ bottomUp (App (Lam pars eff body) args) | length pars == length args && all fre bottomUp (App (TypeApp (Var bind _) _) [App (TypeApp (Var lift _) _) [arg], cont]) | getName bind == nameBind && getName lift == nameLift = App cont [arg] + -- composition extension: c[ctx hole] -> c bottomUp (App (TypeApp (Var cextend _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName cextend == nameCCtxComposeExtend && getName cempty == nameCCtxEmpty = ctx1 diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 73ee190ce..d8665fcbf 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -3,16 +3,23 @@ runparams="100000" # "1 10 100 1000 10000 100000 1000000" runparams_small="1 10 100 1000" benchmarks="rbtree ftree msort qsort tmap" -graphvariants="fip std std-noreuse stl stl-mi std-mi" +graphvariants="fip std-reuse std stl stl-mi std-mi" # note: order matters as it is made relative to the first benches_tmapkk="tmap/tmap-fip.kk tmap/tmap-std.kk" benches_tmapc="tmap/tmap-fip.c tmap/tmap-std.c" benches_rbtreekk="rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std.kk rbtree/rbtree-fip-clrs.kk" benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" -benches_sortkk="sort/msort-fip.kk sort/msort-std.kk sort/qsort-fip.kk sort/qsort-std.kk" -benches_fingerkk="finger/ftree-fip.kk finger/ftree-std.kk" -benches_all="$benches_rbtreekk $benches_rbtreec $benches_fingerkk $benches_sortkk $benches_tmapkk $benches_tmapc" +benches_msortkk="msort/msort-fip.kk msort/msort-std.kk" +benches_qsortkk="qsort/qsort-fip.kk qsort/qsort-std.kk" +benches_ftreekk="ftree/ftree-fip.kk ftree/ftree-std.kk" + +benches_rbtree="$benches_rbtreekk $benches_rbtreec" +benches_msort="$benches_msortkk" +benches_qsort="$benches_qsortkk" +benches_tmap="$benches_tmapkk $benches_tmapc" +benches_ftree="$benches_ftreekk" +benches_all="$benches_rbtree $benches_ftree $benches_msort $benches_qsort $benches_tmap" # get this by running `stack path | grep local-install-root`` in the koka development directory # koka_install_dir="/mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/665c0f3ba306de11186f0f92ea0ca8305283b035f4fa2dfb5c2b12a96689073b/8.10.7" @@ -110,13 +117,15 @@ while : ; do allb) benches="$benches_all";; allkk) benches="$benches $benches_tmapkk $benches_rbtreekk $benches_fingerkk $benches_sortkk";; - tmapkk) benches="$benches $benches_tmapkk";; - rbtreekk) benches="$benches $benches_rbtreekk";; - sortkk) benches="$benches $benches_sortkk";; - fingerkk) benches="$benches $benches_fingerkk";; allc) benches="$benches $benches_tmapc $benches_rbtreec";; - tmapc) benches="$benches $benches_tmapc";; - rbtreec) benches="$benches $benches_rbtreec";; + tmap) benches="$benches $benches_tmap";; + rbtree) benches="$benches $benches_rbtree";; + qsort) benches="$benches $benches_msort";; + msort) benches="$benches $benches_qsort";; + sort) benches="$benches $benches_msort $benches_qsort";; + ftree) benches="$benches $benches_ftree";; + tmap) benches="$benches $benches_tmapc";; + ccomp) ccomp="$flag_arg";; cppcomp) cppcomp="$flag_arg";; @@ -160,13 +169,13 @@ while : ; do shift done -# add -noreuse to std, and -mi to c/cpp +# add -reuse to std, and -mi to c/cpp function expand_benches { local newb="" for bench in $benches; do local base=${bench%.*} if [[ $bench == *-std\.kk ]]; then - newb="$newb $bench $base-noreuse.kk" # order matters + newb="$newb $base-reuse.kk $bench" # order matters elif [[ $bench == *\.c ]]; then newb="$newb $bench $base-mi.c" elif [[ $bench == *\.cpp ]]; then @@ -187,9 +196,11 @@ function build_kk { # local base=${1%.*} # no ext local stem=${base##*/} # dashed dir local options="-O2 --no-debug --cc=$ccomp --buildtag=bench --buildname=$stem $kkopts" - if [[ $1 == *-noreuse\.kk ]]; then + if [[ $1 == *-std-reuse\.kk ]]; then + srcname="${1%-std-reuse.kk}-std.kk" + fi + if [[ $1 == *-std\.kk ]]; then options="$options --fno-reuse" - srcname="${1%-noreuse.kk}.kk" fi if ! [ -f "$benchdir/$srcname" ]; then info "SKIP $bench ($benchdir/$srcname) -- not found" diff --git a/test/fip/src/finger/ftree-fip.kk b/test/fip/src/ftree/ftree-fip.kk similarity index 100% rename from test/fip/src/finger/ftree-fip.kk rename to test/fip/src/ftree/ftree-fip.kk diff --git a/test/fip/src/finger/ftree-std.kk b/test/fip/src/ftree/ftree-std.kk similarity index 100% rename from test/fip/src/finger/ftree-std.kk rename to test/fip/src/ftree/ftree-std.kk diff --git a/test/fip/src/msort/msort-fip.kk b/test/fip/src/msort/msort-fip.kk index 8b0f077b7..452148d73 100644 --- a/test/fip/src/msort/msort-fip.kk +++ b/test/fip/src/msort/msort-fip.kk @@ -94,25 +94,25 @@ fip fun merge(c1 : sublist, c2 : sublist, u : unit2) :
sublist fip fun merge-last-right(a : elem, c2 : sublist, u : unit2) : sublist match c2 - SCons(b, cs2) | a <= b -> SCons(a, SCons(b, cs2)) - | _ -> SCons(b, merge-last-right(a, cs2, u)) - STuple(b, c) -> merge-right(a, Pair(b, c), u) + SCons(b, cs2) -> if a <= b then SCons(a, SCons(b, cs2)) + else SCons(b, merge-last-right(a, cs2, u)) + STuple(b, c) -> merge-right(a, Pair(b, c), u) fip fun merge-last-left(c2 : sublist, d : elem, u : unit2) : sublist match c2 - SCons(a, cs2) | a <= d -> SCons(a, merge-last-left(cs2, d, u)) - | _ -> SCons(d, SCons(a, cs2)) - STuple(a, b) -> merge-left(Pair(a, b), d, u) + SCons(a, cs2) -> if a <= d then SCons(a, merge-last-left(cs2, d, u)) + else SCons(d, SCons(a, cs2)) + STuple(a, b) -> merge-left(Pair(a, b), d, u) fip fun merge-right(a : elem, p : pair, u : unit2) : sublist match p - Pair(b, c) | a <= b -> SCons(a, STuple(b, c)) - | _ -> SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) + Pair(b, c) -> if a <= b then SCons(a, STuple(b, c)) + else SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) fip fun merge-left(p : pair, d : elem, u : unit2) : sublist match p - Pair(a, b) | a <= d -> SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) - | _ -> SCons(d, STuple(a, b)) + Pair(a, b) -> if a <= d then SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) + else SCons(d, STuple(a, b)) fun rand-list(n : int32, seed : int32) :
list val a = 22695477.int32 diff --git a/test/fip/src/qsort/qsort-fip.kk b/test/fip/src/qsort/qsort-fip.kk index d7f94c3c3..1a6e61213 100644 --- a/test/fip/src/qsort/qsort-fip.kk +++ b/test/fip/src/qsort/qsort-fip.kk @@ -39,8 +39,8 @@ fip fun quicksort-app(bdl : partition) : div list SCons(p, xx) -> val (lo, hi) = split-sublist(p, xx, Done, bdl', Unit2(Pad,Pad), Unit2(Pad,Pad)) quicksort-go(lo, hi) - STuple(a, b) | a <= b -> Cons(a, Cons(b, quicksort-app(bdl'))) - | _ -> Cons(b, Cons(a, quicksort-app(bdl'))) + STuple(a, b) -> if a <= b then Cons(a, Cons(b, quicksort-app(bdl'))) + else Cons(b, Cons(a, quicksort-app(bdl'))) End -> Nil type accum @@ -50,16 +50,16 @@ type accum fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) match xs - Cons(x, xx) | x < p -> split-list(p, xx, MkLo(x, k), b, u) - | _ -> split-list(p, xx, MkHi(x, k), b, u) + Cons(x, xx) -> if x < p then split-list(p, xx, MkLo(x, k), b, u) + else split-list(p, xx, MkHi(x, k), b, u) Nil -> val (lo, hi) = split-app1(k, Nil, Nothing2, b) (lo, Singleton(p, hi)) fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) match xs - SCons(x, xx) | x < p -> split-sublist(p, xx, MkLo(x, k), b, u, u1) - | _ -> split-sublist(p, xx, MkHi(x, k), b, u, u1) + SCons(x, xx) -> if x < p then split-sublist(p, xx, MkLo(x, k), b, u, u1) + else split-sublist(p, xx, MkHi(x, k), b, u, u1) STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) fip fun split-app1(k : accum, lo : list, hi : maybe2, b : partition) :
(list, partition) From 9f0af6ae7d9ec67ccd89c0c0637b1c381a41b46f Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 10:08:28 -0700 Subject: [PATCH 193/233] update readme for fip artifact --- test/fip/README.md | 172 ++++++++++++++++++++++++++++++++++++++++----- test/fip/bench.sh | 4 +- 2 files changed, 157 insertions(+), 19 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index e8d9f630d..9fcd5b23a 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -1,23 +1,169 @@ -# Benchmarking +# ICFP 2023 Paper Artifact: FP^2: Fully in-Place Functional Programming -Run in the `bench` directory as: +Anton Lorenzen, Daan Leijen, and Wouter Swierstra + +# Getting Started + +Go to the test directory: + +``` +> cd dev/koka/test/fip +``` + +We will shorten this directory to `test#` in the guide. +This directory also contains this README.md. + +From this prompt, we can run our benchmarks as: + +``` +test# ./bench.sh rbtree run + +~/home/dev/koka ~/home/dev/koka/test/fip +~/home/dev/koka/test/fip +using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa +expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk rbtree/rbtrep + +run kk__rbtree-fip__100000, iter 1, cmd: .koka/v2.4.1-bench/clang-release/rbtree-fip +total: 1000000 +elapsed: 0.60s, user: 0.59s, sys: 0.00s, rss: 6988kb + +... + +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.60 1.000 0 6988 +kk rbtree fip-icfp 100000 0.53 .883 0 6928 +kk rbtree std-reuse 100000 0.61 1.016 0 6940 +kk rbtree std 100000 1.53 2.550 0 7048 +kk rbtree fip-clrs 100000 0.78 1.300 0 7056 +c rbtree clrs 100000 0.68 1.133 0 6252 +c rbtree clrs-mi 100000 0.57 .950 0 8080 +c rbtree clrs-full 100000 0.68 1.133 0 6404 +c rbtree clrs-full-mi 100000 0.57 .950 0 8084 +cpp rbtree stl 100000 0.88 1.466 0 8528 +cpp rbtree stl-mi 100000 0.58 .966 0 10136 +``` + +This runs the `rbtree` benchmark on various variants +and eventually provides a summary in absolute runtimes (and rss), and normalized +runtimes relative to the Koka fip variant. + +Note that the precise results depend quite a bit on the host system -- the above results +are on a Windows 11 16-core AMD 7950X @ 4.5Ghz inside a Debian QEMU image. + + +# Step-by-step Guide + +## Run All Benchmarks + +The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure +the runtime and rss. For the benchmark figures in our paper we used +the following command: + +``` +test# ./bench.sh allb run -n=10 +``` + +to run all benchmarks 10 times for each available language, and use the median +of those runs (and calculate the standard error interval). + +The expected results on an AMD7950X are at the bottom of this readme. +These should correspond closely to the results in Section 6 of the paper and +support the conclusions drawn there. + + +## Benchmark Descriptions + +The benchmarks are described in detail in the paper. + +- `rbtree` : inserts 42 million items into a red-black tree. +- `ftree` : +- `msort` : +- `qsort` : +- `tmap` : + +Each benchmark comes in different variants: + +- `fip` +- `std-reuse` +- `std` +- C `stl`/`std` +- C `stl-mi`/`std-mi` +- `rbtree-clrs` + + +## Benchmark Sources + +All the sources are in the `test/src` directories. For example: +``` +test# ls src/msort +msort-fip.kk msort-std.kk +``` + +## Re-build the Benchmarks + +All tests can be recompiled using: ``` -./bench.sh allb build run +test# ./bench.sh allb build ``` -Options: +Further options: -* `allb`: all benchmarks (also `allkk` and `allml` to select a subset, or `tmapkk`, `mapkk`, `rbtreekk`, or `kskk`). +* `allb`: all benchmarks (also `allkk` and `allc` to select a subset, or `rbtree`, `msort`, `qsort`, `ftree`, and `tmap`). * `build`: build benchmarks. * `run`: run benchmarks and show benchmark scores (calculating median and stddev). * `-n=<`N`>`: run each benchmark N times. * `koka=`: set koka compiler command explicitly. -* `ocamlopt=`: set ocamlopt command explicitly. -* `ccomp=`: set C compiler for Koka, either `clang` or `gcc` (or `gcc-`). -* `small`: do a small run for lists 0, 1, and 10. +* `ccomp=`: set C compiler, either `clang` or `gcc` (or `gcc-`). The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. + +## Expected Results in a Debian QEMU on Windows: + +These were obtained running on Windows 11 with a 16-core AMD 7950X @ 4.5Ghz, +using the standard Debian QEMU image. + +``` +test# ./bench allb build run -n=10 +... +``` + +``` +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.59 1.000 .0057735 6944 +kk rbtree fip-icfp 100000 0.53 .898 .0051846 6916 +kk rbtree std-reuse 100000 0.61 1.033 .0059640 6900 +kk rbtree std 100000 1.48 2.508 .1023885 6936 +kk rbtree fip-clrs 100000 0.78 1.322 .0076325 6940 +c rbtree clrs 100000 0.68 1.152 .0066510 6368 +c rbtree clrs-mi 100000 0.57 .966 0 7944 +c rbtree clrs-full 100000 0.67 1.135 .0065529 6404 +c rbtree clrs-full-mi 100000 0.57 .966 0 7948 +cpp rbtree stl 100000 0.88 1.491 .0086082 8440 +cpp rbtree stl-mi 100000 0.58 .983 0 10168 +## +kk ftree fip 100000 0.83 1.000 .0057735 7036 +kk ftree std-reuse 100000 0.90 1.084 .075101 6912 +kk ftree std 100000 1.32 1.590 .0091798 6808 +## +kk msort fip 100000 0.92 1.000 .0057735 9064 +kk msort std-reuse 100000 0.90 .978 .0056464 11588 +kk msort std 100000 1.17 1.271 .01037767 11552 +## +kk qsort fip 100000 1.13 1.000 .0057735 14588 +kk qsort std-reuse 100000 1.48 1.309 .0226725 15140 +kk qsort std 100000 2.13 1.884 .0543863 15116 +## +kk tmap fip 100000 1.13 1.000 .0238048 11144 +kk tmap std-reuse 100000 0.80 .707 .00577263 11016 +kk tmap std 100000 0.82 .725 .0041857 11152 +c tmap fip 100000 1.36 1.203 .0208365 7968 +c tmap fip-mi 100000 0.59 .522 .0030137 9992 +c tmap std 100000 1.44 1.274 .0073554 7912 +c tmap std-mi 100000 0.63 .557 .0032158 9952 +``` + + # Prerequisites ## GNU time @@ -27,15 +173,9 @@ Install gnu time if you don't have it: GNU time 1.7 ``` -## Koka Dev. - -Pull the `dev` branch of koka and build it. -Modify the `bench.sh` script to let `koka_dev_dir` point -to the development directory. - ## Mimalloc -The `*_mimalloc.c` benchmarks rely on mimalloc: +The C benchmarks rely on mimalloc: ``` # git clone https://github.com/microsoft/mimalloc @@ -47,5 +187,3 @@ The `*_mimalloc.c` benchmarks rely on mimalloc: # sudo make install ``` -The `build_c` function in `bench.sh` links against mimalloc. -This was only tested on Mac OS X and may have to be modified for other systems. \ No newline at end of file diff --git a/test/fip/bench.sh b/test/fip/bench.sh index d8665fcbf..6dd93dea7 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -120,8 +120,8 @@ while : ; do allc) benches="$benches $benches_tmapc $benches_rbtreec";; tmap) benches="$benches $benches_tmap";; rbtree) benches="$benches $benches_rbtree";; - qsort) benches="$benches $benches_msort";; - msort) benches="$benches $benches_qsort";; + qsort) benches="$benches $benches_qsort";; + msort) benches="$benches $benches_msort";; sort) benches="$benches $benches_msort $benches_qsort";; ftree) benches="$benches $benches_ftree";; tmap) benches="$benches $benches_tmapc";; From 409f100c94b3906a77f4c802bf3f96d97c71fcd0 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 14:17:57 -0700 Subject: [PATCH 194/233] link with pthread --- test/fip/README.md | 12 +++++------- test/fip/bench.sh | 4 ++-- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index 9fcd5b23a..525d1bd1f 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -7,7 +7,7 @@ Anton Lorenzen, Daan Leijen, and Wouter Swierstra Go to the test directory: ``` -> cd dev/koka/test/fip +> cd koka/test/fip ``` We will shorten this directory to `test#` in the guide. @@ -21,7 +21,7 @@ test# ./bench.sh rbtree run ~/home/dev/koka ~/home/dev/koka/test/fip ~/home/dev/koka/test/fip using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa -expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk rbtree/rbtrep +expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk ... run kk__rbtree-fip__100000, iter 1, cmd: .koka/v2.4.1-bench/clang-release/rbtree-fip total: 1000000 @@ -47,8 +47,7 @@ This runs the `rbtree` benchmark on various variants and eventually provides a summary in absolute runtimes (and rss), and normalized runtimes relative to the Koka fip variant. -Note that the precise results depend quite a bit on the host system -- the above results -are on a Windows 11 16-core AMD 7950X @ 4.5Ghz inside a Debian QEMU image. +Note that the precise results depend quite a bit on the host system -- the above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. # Step-by-step Guide @@ -118,10 +117,9 @@ Further options: The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. -## Expected Results in a Debian QEMU on Windows: +## Expected Results -These were obtained running on Windows 11 with a 16-core AMD 7950X @ 4.5Ghz, -using the standard Debian QEMU image. +These were obtained running on Ubuntu 22.0.4 on a 16-core AMD 7950X @ 4.5Ghz. ``` test# ./bench allb build run -n=10 diff --git a/test/fip/bench.sh b/test/fip/bench.sh index 6dd93dea7..2e41ce948 100755 --- a/test/fip/bench.sh +++ b/test/fip/bench.sh @@ -44,10 +44,10 @@ koka_ver="v2.4.1" echo "using koka: $koka" coutdir=".koka/ccomp" -copts="" +copts="-lpthread" cppoutdir=".koka/cppcomp" -cppopts="" +cppopts="-lpthread" mimalloc_o="/usr/local/lib/mimalloc-2.1/mimalloc.o" From 5295a0d9407e16949e33159fb26003a8c0d7f93c Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 14:22:58 -0700 Subject: [PATCH 195/233] add sentence on relative performance --- test/fip/README.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/fip/README.md b/test/fip/README.md index 525d1bd1f..d3d21a496 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -67,7 +67,9 @@ of those runs (and calculate the standard error interval). The expected results on an AMD7950X are at the bottom of this readme. These should correspond closely to the results in Section 6 of the paper and -support the conclusions drawn there. +support the conclusions drawn there. Note that the results can differ quite +bit among different systems but if not running in emulation, the relative times +should be quite similar. ## Benchmark Descriptions From 5050346790a7d0dcb640dc31e3296d0690b78ac1 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 14:44:36 -0700 Subject: [PATCH 196/233] small edits --- test/fip/README.md | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index d3d21a496..7060c51fd 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -47,7 +47,9 @@ This runs the `rbtree` benchmark on various variants and eventually provides a summary in absolute runtimes (and rss), and normalized runtimes relative to the Koka fip variant. -Note that the precise results depend quite a bit on the host system -- the above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. +Note that the precise results depend quite a bit on the host system, but the +relative performance should be similar (except when running in emulation). +The above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. # Step-by-step Guide @@ -65,10 +67,10 @@ test# ./bench.sh allb run -n=10 to run all benchmarks 10 times for each available language, and use the median of those runs (and calculate the standard error interval). -The expected results on an AMD7950X are at the bottom of this readme. +The full expected results on an AMD7950X are at the bottom of this readme. These should correspond closely to the results in Section 6 of the paper and support the conclusions drawn there. Note that the results can differ quite -bit among different systems but if not running in emulation, the relative times +bit among different systems, but if not running in emulation, the relative times should be quite similar. From e18b89ba1ed2f9c118017ee175af9a2dc0a4d1a3 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 14:52:53 -0700 Subject: [PATCH 197/233] add reference to the fip paper --- test/fip/README.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index 7060c51fd..dc735650d 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -68,11 +68,14 @@ to run all benchmarks 10 times for each available language, and use the median of those runs (and calculate the standard error interval). The full expected results on an AMD7950X are at the bottom of this readme. -These should correspond closely to the results in Section 6 of the paper and -support the conclusions drawn there. Note that the results can differ quite +These should correspond closely to the results in Section 6 of the paper (Figure 10) +and support the conclusions drawn there. Note that the results can differ quite bit among different systems, but if not running in emulation, the relative times should be quite similar. +Note: for convenience, the image contains the revised paper as +`fip-icfp23-submission.pdf` in the `~` directory. + ## Benchmark Descriptions From 16417ec14409de842020d24cf8999c577aa120b9 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 14:59:31 -0700 Subject: [PATCH 198/233] add pointers to the sources --- test/fip/README.md | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index dc735650d..1d7c6ca1f 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -7,17 +7,18 @@ Anton Lorenzen, Daan Leijen, and Wouter Swierstra Go to the test directory: ``` -> cd koka/test/fip +# cd koka/test/fip ``` We will shorten this directory to `test#` in the guide. -This directory also contains this README.md. +This directory also contains this `README.md`. From this prompt, we can run our benchmarks as: ``` test# ./bench.sh rbtree run - +``` +``` ~/home/dev/koka ~/home/dev/koka/test/fip ~/home/dev/koka/test/fip using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa @@ -105,6 +106,11 @@ test# ls src/msort msort-fip.kk msort-std.kk ``` +The main implementation of the FIP check can be found in +`koka/src/Core/CheckFBIP.hs`, while the main Perceus +reuse analysis is in `koka/src/Backend/C/ParcReuse.hs`. + + ## Re-build the Benchmarks All tests can be recompiled using: From f80b6f02f56289ee40083dab60276b9ed1d12c35 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 15:13:13 -0700 Subject: [PATCH 199/233] add detailed build instructions --- test/fip/README.md | 53 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 14 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index 1d7c6ca1f..ce692073f 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -175,26 +175,51 @@ c tmap std-mi 100000 0.63 .557 .0032158 9952 ``` -# Prerequisites +# Building from Scratch + +These are instructions to re-create the image on a Unix system. + +Basics: + +``` +sudo apt update +sudo apt ugrade +sudo apt-get install -y --no-install-recommends ca-certificates +sudo apt-get install -y --no-install-recommends libc-dev build-essential time bc +sudo apt-get install -y --no-install-recommends tar cmake curl +sudo apt-get install -y --no-install-recommends gcc clang +``` + +Stack: -## GNU time -Install gnu time if you don't have it: ``` -# /usr/bin/time --version -GNU time 1.7 +curl -sSL https://get.haskellstack.org | sh ``` -## Mimalloc +Mimalloc: -The C benchmarks rely on mimalloc: +``` +git clone https://github.com/microsoft/mimalloc +cd mimalloc +mkdir -p out/release +cd out/release +cmake ../.. +make +sudo make install +cd ~ +``` + +Koka: ``` -# git clone https://github.com/microsoft/mimalloc -# cd mimalloc -# mkdir -p out/release -# cd out/release -# cmake ../.. -# make -# sudo make install +git clone --recursive https://github.com/koka-lang/koka -b dev-fbip +cd koka +stack build --fast ``` +And go to the test directory to build and run a benchmark: + +``` +cd ~/koka/test/fip +./bench.sh rbtree build run +``` From e3945d7ed438d3c5061a4c92723a68c11ca80523 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 15:24:40 -0700 Subject: [PATCH 200/233] add commit hash --- test/fip/README.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index ce692073f..1e664dd4b 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -199,7 +199,7 @@ curl -sSL https://get.haskellstack.org | sh Mimalloc: ``` -git clone https://github.com/microsoft/mimalloc +git clone https://github.com/microsoft/mimalloc -b v2.1.1 cd mimalloc mkdir -p out/release cd out/release @@ -209,11 +209,12 @@ sudo make install cd ~ ``` -Koka: +Koka, commit f80b6f02 ``` git clone --recursive https://github.com/koka-lang/koka -b dev-fbip cd koka +git checkout f80b6f02 stack build --fast ``` From fb6776f2704e7d30345d10eff3707b8b35889f42 Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Tue, 30 May 2023 15:30:01 -0700 Subject: [PATCH 201/233] Describe benchmarks --- test/fip/README.md | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index 1e664dd4b..c3360183d 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -82,20 +82,32 @@ Note: for convenience, the image contains the revised paper as The benchmarks are described in detail in the paper. -- `rbtree` : inserts 42 million items into a red-black tree. -- `ftree` : -- `msort` : -- `qsort` : -- `tmap` : +- `rbtree` : For 100 iterations: Create a red-black tree by successively inserting the integers 100_000 to 1. +- `ftree` : For 100 iterations: Create a finger-tree by successively snoc-ing the integers 100_000 to 1, + then uncons an element from the front and snoc it to the back 300_000 times. +- `msort` : Create a list of 100_000 random integers. For 100 iterations, run mergesort on this list. +- `qsort` : Create a list of 100_000 random integers. For 100 iterations, run quicksort on this list. +- `tmap` : Create a perfectly balanced tree of the integers 1 to 100_000. + For 1000 iterations: Create a copy of the tree where each integer is increased by one. Each benchmark comes in different variants: -- `fip` -- `std-reuse` -- `std` -- C `stl`/`std` -- C `stl-mi`/`std-mi` -- `rbtree-clrs` +- `fip`: A fully in-place algorithm. All as presented in the paper, + except for `rbtree` where we use the faster algorithm presented + last year and add the algorithm from the paper as `rbtree-clrs`. +- `std-reuse`: The typical functional algorithm ... + - `rbtree` : as presented by Okasaki. + - `ftree` : as presented by Claessen. + - `msort` : as in Haskell's Data.List.sort + (with list reversal instead of closures + in `ascending` to improve speed). + - `qsort`, `tmap` : the obvious, recursive implementation. +- `std`: Like `std-reuse` but compiled with `--fno-reuse`. +- C `std`: + - `rbtree`: A C implementation of the algorithm in Cormen et al. + - `tmap`: A C implementation using pointer reversal (corresponding to `fip`). +- C `std-mi`: As `std` but linked against the mimalloc allocator. +- C++ `stl`: The red-black tree in `std::map`. ## Benchmark Sources From 54a16a5ad2034b33383abe58e3ef243646ced0ec Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 15:34:56 -0700 Subject: [PATCH 202/233] small edits --- test/fip/README.md | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index c3360183d..f7b6da1df 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -1,7 +1,5 @@ # ICFP 2023 Paper Artifact: FP^2: Fully in-Place Functional Programming -Anton Lorenzen, Daan Leijen, and Wouter Swierstra - # Getting Started Go to the test directory: @@ -88,19 +86,18 @@ The benchmarks are described in detail in the paper. - `msort` : Create a list of 100_000 random integers. For 100 iterations, run mergesort on this list. - `qsort` : Create a list of 100_000 random integers. For 100 iterations, run quicksort on this list. - `tmap` : Create a perfectly balanced tree of the integers 1 to 100_000. - For 1000 iterations: Create a copy of the tree where each integer is increased by one. + For 1000 iterations: Create a copy of the _shared_ tree where each integer is increased by one. Each benchmark comes in different variants: - `fip`: A fully in-place algorithm. All as presented in the paper, - except for `rbtree` where we use the faster algorithm presented - last year and add the algorithm from the paper as `rbtree-clrs`. + except for `rbtree` where we use the algorithm presented at ICFP'22 + on frame-limited reuse, and we add the algorithm from the paper as `rbtree-clrs`. - `std-reuse`: The typical functional algorithm ... - `rbtree` : as presented by Okasaki. - `ftree` : as presented by Claessen. - `msort` : as in Haskell's Data.List.sort - (with list reversal instead of closures - in `ascending` to improve speed). + (with list reversal instead of closures in `ascending` to improve speed). - `qsort`, `tmap` : the obvious, recursive implementation. - `std`: Like `std-reuse` but compiled with `--fno-reuse`. - C `std`: @@ -108,9 +105,10 @@ Each benchmark comes in different variants: - `tmap`: A C implementation using pointer reversal (corresponding to `fip`). - C `std-mi`: As `std` but linked against the mimalloc allocator. - C++ `stl`: The red-black tree in `std::map`. +- C++ `stl-mi`: As `stl-mi` but linked against the mimalloc allocator. -## Benchmark Sources +## Sources All the sources are in the `test/src` directories. For example: ``` From af22d5e506610ee9893da91634fd6f24ab9b6ce3 Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 30 May 2023 15:35:47 -0700 Subject: [PATCH 203/233] update hash --- test/fip/README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/fip/README.md b/test/fip/README.md index f7b6da1df..a150e039d 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -219,12 +219,12 @@ sudo make install cd ~ ``` -Koka, commit f80b6f02 +Koka, commit 54a16a5 ``` git clone --recursive https://github.com/koka-lang/koka -b dev-fbip cd koka -git checkout f80b6f02 +git checkout 54a16a5 stack build --fast ``` From 234a793a9151f95726b033ee96745b3f02f562c8 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 2 Jun 2023 18:51:33 -0700 Subject: [PATCH 204/233] updates for artifact --- .../ide/vs2022/kklib-test-interactive.vcxproj | 9 + .../kklib-test-interactive.vcxproj.filters | 9 + kklib/ide/vs2022/kklib-test.vcxproj.filters | 40 +- kklib/include/kklib.h | 4 +- lib/std/core/types.kk | 3 +- lib/std/num/random.kk | 12 +- test/fip/README.md | 472 +++++++++--------- 7 files changed, 286 insertions(+), 263 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index ab10762b6..e4052265c 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,9 +165,18 @@ + + + + + + + + + diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index 55bde7b20..812840709 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -5,6 +5,15 @@ + + + + + + + + + diff --git a/kklib/ide/vs2022/kklib-test.vcxproj.filters b/kklib/ide/vs2022/kklib-test.vcxproj.filters index 9af54515c..457c09591 100644 --- a/kklib/ide/vs2022/kklib-test.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test.vcxproj.filters @@ -1,21 +1,21 @@ - - - - - {cfad405d-6bd1-44d5-9731-40fc308f3cfd} - - - - - Source Files - - - Source Files - - - - - Source Files - - + + + + + {cfad405d-6bd1-44d5-9731-40fc308f3cfd} + + + + + Source Files + + + Source Files + + + + + Source Files + + \ No newline at end of file diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index e4760444f..3a37543eb 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 106 // modify on changes to trigger recompilation +#define KKLIB_BUILD 107 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -336,7 +336,7 @@ static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { #define MI_MAX_ALIGN_SIZE KK_MIMALLOC #else #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE - #endif + #endif #endif #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) #define MI_DEBUG 3 diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 042307838..dfa6c7422 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -178,9 +178,10 @@ pub type order pub value type box con Box( unbox : a ) + /* // Explicitly heap allocate using the `Hbox` constructor. -pub reference type hbox +pub ref type hbox con Hbox( unhbox : a ) pub fun hbox( x : a ) : hbox diff --git a/lib/std/num/random.kk b/lib/std/num/random.kk index a975b5563..e2b738ed2 100644 --- a/lib/std/num/random.kk +++ b/lib/std/num/random.kk @@ -39,9 +39,9 @@ pub fun strong-random(action : () -> a) : a // The chance of a cycle of less than 2^(32+max(96-k,0)) is 2^-(32+k), // (e.g. the chance of a cycle of less than 2^48 is 2^-80). // -struct sfc(x:int32, y:int32, z:int32, cnt:int32) +abstract value struct sfc(x:int32, y:int32, z:int32, cnt:int32) -fun sfc-step( sfc : sfc ) : (int32,sfc) +pub fun sfc-step( sfc : sfc ) : (int32,sfc) match sfc Sfc(x,y,z,cnt) -> val res = x + y + cnt @@ -50,11 +50,15 @@ fun sfc-step( sfc : sfc ) : (int32,sfc) rotl(z,21) + res, cnt + 1.int32 )) -fun sfc-init( seed : int ) : sfc - val sfc0 = Sfc(0.int32, seed.int32, (seed / 0x100000000).int32, 1.int32) +pub fun sfc-init32( seed1 : int32, seed2 : int32 ) : sfc + val sfc0 = Sfc(0.int32, seed1, seed2, 1.int32) fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).snd } ) // step 12 times +pub fun sfc-init( seed : int ) : sfc + sfc-init32(seed.int32, (seed / 0x100000000).int32) + + // Use pseudo random numbers given some initial `seed`. At most // 64-bits of the initial seed are used. Do not use this for // cryptographic applications (use `strong-random` instead). diff --git a/test/fip/README.md b/test/fip/README.md index a150e039d..bcd3fc0d6 100644 --- a/test/fip/README.md +++ b/test/fip/README.md @@ -1,236 +1,236 @@ -# ICFP 2023 Paper Artifact: FP^2: Fully in-Place Functional Programming - -# Getting Started - -Go to the test directory: - -``` -# cd koka/test/fip -``` - -We will shorten this directory to `test#` in the guide. -This directory also contains this `README.md`. - -From this prompt, we can run our benchmarks as: - -``` -test# ./bench.sh rbtree run -``` -``` -~/home/dev/koka ~/home/dev/koka/test/fip -~/home/dev/koka/test/fip -using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa -expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk ... - -run kk__rbtree-fip__100000, iter 1, cmd: .koka/v2.4.1-bench/clang-release/rbtree-fip -total: 1000000 -elapsed: 0.60s, user: 0.59s, sys: 0.00s, rss: 6988kb - -... - -# benchmark variant param elapsed relative stddev rss -kk rbtree fip 100000 0.60 1.000 0 6988 -kk rbtree fip-icfp 100000 0.53 .883 0 6928 -kk rbtree std-reuse 100000 0.61 1.016 0 6940 -kk rbtree std 100000 1.53 2.550 0 7048 -kk rbtree fip-clrs 100000 0.78 1.300 0 7056 -c rbtree clrs 100000 0.68 1.133 0 6252 -c rbtree clrs-mi 100000 0.57 .950 0 8080 -c rbtree clrs-full 100000 0.68 1.133 0 6404 -c rbtree clrs-full-mi 100000 0.57 .950 0 8084 -cpp rbtree stl 100000 0.88 1.466 0 8528 -cpp rbtree stl-mi 100000 0.58 .966 0 10136 -``` - -This runs the `rbtree` benchmark on various variants -and eventually provides a summary in absolute runtimes (and rss), and normalized -runtimes relative to the Koka fip variant. - -Note that the precise results depend quite a bit on the host system, but the -relative performance should be similar (except when running in emulation). -The above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. - - -# Step-by-step Guide - -## Run All Benchmarks - -The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure -the runtime and rss. For the benchmark figures in our paper we used -the following command: - -``` -test# ./bench.sh allb run -n=10 -``` - -to run all benchmarks 10 times for each available language, and use the median -of those runs (and calculate the standard error interval). - -The full expected results on an AMD7950X are at the bottom of this readme. -These should correspond closely to the results in Section 6 of the paper (Figure 10) -and support the conclusions drawn there. Note that the results can differ quite -bit among different systems, but if not running in emulation, the relative times -should be quite similar. - -Note: for convenience, the image contains the revised paper as -`fip-icfp23-submission.pdf` in the `~` directory. - - -## Benchmark Descriptions - -The benchmarks are described in detail in the paper. - -- `rbtree` : For 100 iterations: Create a red-black tree by successively inserting the integers 100_000 to 1. -- `ftree` : For 100 iterations: Create a finger-tree by successively snoc-ing the integers 100_000 to 1, - then uncons an element from the front and snoc it to the back 300_000 times. -- `msort` : Create a list of 100_000 random integers. For 100 iterations, run mergesort on this list. -- `qsort` : Create a list of 100_000 random integers. For 100 iterations, run quicksort on this list. -- `tmap` : Create a perfectly balanced tree of the integers 1 to 100_000. - For 1000 iterations: Create a copy of the _shared_ tree where each integer is increased by one. - -Each benchmark comes in different variants: - -- `fip`: A fully in-place algorithm. All as presented in the paper, - except for `rbtree` where we use the algorithm presented at ICFP'22 - on frame-limited reuse, and we add the algorithm from the paper as `rbtree-clrs`. -- `std-reuse`: The typical functional algorithm ... - - `rbtree` : as presented by Okasaki. - - `ftree` : as presented by Claessen. - - `msort` : as in Haskell's Data.List.sort - (with list reversal instead of closures in `ascending` to improve speed). - - `qsort`, `tmap` : the obvious, recursive implementation. -- `std`: Like `std-reuse` but compiled with `--fno-reuse`. -- C `std`: - - `rbtree`: A C implementation of the algorithm in Cormen et al. - - `tmap`: A C implementation using pointer reversal (corresponding to `fip`). -- C `std-mi`: As `std` but linked against the mimalloc allocator. -- C++ `stl`: The red-black tree in `std::map`. -- C++ `stl-mi`: As `stl-mi` but linked against the mimalloc allocator. - - -## Sources - -All the sources are in the `test/src` directories. For example: -``` -test# ls src/msort -msort-fip.kk msort-std.kk -``` - -The main implementation of the FIP check can be found in -`koka/src/Core/CheckFBIP.hs`, while the main Perceus -reuse analysis is in `koka/src/Backend/C/ParcReuse.hs`. - - -## Re-build the Benchmarks - -All tests can be recompiled using: -``` -test# ./bench.sh allb build -``` - -Further options: - -* `allb`: all benchmarks (also `allkk` and `allc` to select a subset, or `rbtree`, `msort`, `qsort`, `ftree`, and `tmap`). -* `build`: build benchmarks. -* `run`: run benchmarks and show benchmark scores (calculating median and stddev). -* `-n=<`N`>`: run each benchmark N times. -* `koka=`: set koka compiler command explicitly. -* `ccomp=`: set C compiler, either `clang` or `gcc` (or `gcc-`). - -The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. - - -## Expected Results - -These were obtained running on Ubuntu 22.0.4 on a 16-core AMD 7950X @ 4.5Ghz. - -``` -test# ./bench allb build run -n=10 -... -``` - -``` -# benchmark variant param elapsed relative stddev rss -kk rbtree fip 100000 0.59 1.000 .0057735 6944 -kk rbtree fip-icfp 100000 0.53 .898 .0051846 6916 -kk rbtree std-reuse 100000 0.61 1.033 .0059640 6900 -kk rbtree std 100000 1.48 2.508 .1023885 6936 -kk rbtree fip-clrs 100000 0.78 1.322 .0076325 6940 -c rbtree clrs 100000 0.68 1.152 .0066510 6368 -c rbtree clrs-mi 100000 0.57 .966 0 7944 -c rbtree clrs-full 100000 0.67 1.135 .0065529 6404 -c rbtree clrs-full-mi 100000 0.57 .966 0 7948 -cpp rbtree stl 100000 0.88 1.491 .0086082 8440 -cpp rbtree stl-mi 100000 0.58 .983 0 10168 -## -kk ftree fip 100000 0.83 1.000 .0057735 7036 -kk ftree std-reuse 100000 0.90 1.084 .075101 6912 -kk ftree std 100000 1.32 1.590 .0091798 6808 -## -kk msort fip 100000 0.92 1.000 .0057735 9064 -kk msort std-reuse 100000 0.90 .978 .0056464 11588 -kk msort std 100000 1.17 1.271 .01037767 11552 -## -kk qsort fip 100000 1.13 1.000 .0057735 14588 -kk qsort std-reuse 100000 1.48 1.309 .0226725 15140 -kk qsort std 100000 2.13 1.884 .0543863 15116 -## -kk tmap fip 100000 1.13 1.000 .0238048 11144 -kk tmap std-reuse 100000 0.80 .707 .00577263 11016 -kk tmap std 100000 0.82 .725 .0041857 11152 -c tmap fip 100000 1.36 1.203 .0208365 7968 -c tmap fip-mi 100000 0.59 .522 .0030137 9992 -c tmap std 100000 1.44 1.274 .0073554 7912 -c tmap std-mi 100000 0.63 .557 .0032158 9952 -``` - - -# Building from Scratch - -These are instructions to re-create the image on a Unix system. - -Basics: - -``` -sudo apt update -sudo apt ugrade -sudo apt-get install -y --no-install-recommends ca-certificates -sudo apt-get install -y --no-install-recommends libc-dev build-essential time bc -sudo apt-get install -y --no-install-recommends tar cmake curl -sudo apt-get install -y --no-install-recommends gcc clang -``` - -Stack: - -``` -curl -sSL https://get.haskellstack.org | sh -``` - -Mimalloc: - -``` -git clone https://github.com/microsoft/mimalloc -b v2.1.1 -cd mimalloc -mkdir -p out/release -cd out/release -cmake ../.. -make -sudo make install -cd ~ -``` - -Koka, commit 54a16a5 - -``` -git clone --recursive https://github.com/koka-lang/koka -b dev-fbip -cd koka -git checkout 54a16a5 -stack build --fast -``` - -And go to the test directory to build and run a benchmark: - -``` -cd ~/koka/test/fip -./bench.sh rbtree build run -``` +# ICFP 2023 Paper Artifact: FP^2: Fully in-Place Functional Programming + +# Getting Started + +Go to the test directory: + +``` +# cd koka/test/fip +``` + +We will shorten this directory to `test#` in the guide. +This directory also contains this `README.md`. + +From this prompt, we can run our benchmarks as: + +``` +test# ./bench.sh rbtree run +``` +``` +~/home/dev/koka ~/home/dev/koka/test/fip +~/home/dev/koka/test/fip +using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa +expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk ... + +run kk__rbtree-fip__100000, iter 1, cmd: .koka/v2.4.1-bench/clang-release/rbtree-fip +total: 1000000 +elapsed: 0.60s, user: 0.59s, sys: 0.00s, rss: 6988kb + +... + +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.60 1.000 0 6988 +kk rbtree fip-icfp 100000 0.53 .883 0 6928 +kk rbtree std-reuse 100000 0.61 1.016 0 6940 +kk rbtree std 100000 1.53 2.550 0 7048 +kk rbtree fip-clrs 100000 0.78 1.300 0 7056 +c rbtree clrs 100000 0.68 1.133 0 6252 +c rbtree clrs-mi 100000 0.57 .950 0 8080 +c rbtree clrs-full 100000 0.68 1.133 0 6404 +c rbtree clrs-full-mi 100000 0.57 .950 0 8084 +cpp rbtree stl 100000 0.88 1.466 0 8528 +cpp rbtree stl-mi 100000 0.58 .966 0 10136 +``` + +This runs the `rbtree` benchmark on various variants +and eventually provides a summary in absolute runtimes (and rss), and normalized +runtimes relative to the Koka fip variant. + +Note that the precise results depend quite a bit on the host system, but the +relative performance should be similar (except when running in emulation). +The above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. + + +# Step-by-step Guide + +## Run All Benchmarks + +The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure +the runtime and rss. For the benchmark figures in our paper we used +the following command: + +``` +test# ./bench.sh allb run -n=10 +``` + +to run all benchmarks 10 times for each available language, and use the median +of those runs (and calculate the standard error interval). + +The full expected results on an AMD7950X are at the bottom of this readme. +These should correspond closely to the results in Section 6 of the paper (Figure 10) +and support the conclusions drawn there. Note that the results can differ quite +bit among different systems, but if not running in emulation, the relative times +should be quite similar. + +Note: for convenience, the image contains the revised paper as +`fip-icfp23-submission.pdf` in the `~` directory. + + +## Benchmark Descriptions + +The benchmarks are described in detail in the paper. + +- `rbtree` : For 100 iterations: Create a red-black tree by successively inserting the integers 100_000 to 1. +- `ftree` : For 100 iterations: Create a finger-tree by successively snoc-ing the integers 100_000 to 1, + then uncons an element from the front and snoc it to the back 300_000 times. +- `msort` : Create a list of 100_000 random integers. For 100 iterations, run mergesort on this list. +- `qsort` : Create a list of 100_000 random integers. For 100 iterations, run quicksort on this list. +- `tmap` : Create a perfectly balanced tree of the integers 1 to 100_000. + For 1000 iterations: Create a copy of the _shared_ tree where each integer is increased by one. + +Each benchmark comes in different variants: + +- `fip`: A fully in-place algorithm. All as presented in the paper, + except for `rbtree` where we use the algorithm presented at ICFP'22 + on frame-limited reuse, and we add the algorithm from the paper as `rbtree-clrs`. +- `std-reuse`: The typical functional algorithm ... + - `rbtree` : as presented by Okasaki. + - `ftree` : as presented by Claessen. + - `msort` : as in Haskell's Data.List.sort + (with list reversal instead of closures in `ascending` to improve speed). + - `qsort`, `tmap` : the obvious, recursive implementation. +- `std`: Like `std-reuse` but compiled with `--fno-reuse`. +- C `std`: + - `rbtree`: A C implementation of the algorithm in Cormen et al. + - `tmap`: A C implementation using pointer reversal (corresponding to `fip`). +- C `std-mi`: As `std` but linked against the mimalloc allocator. +- C++ `stl`: The red-black tree in `std::map`. +- C++ `stl-mi`: As `stl-mi` but linked against the mimalloc allocator. + + +## Sources + +All the sources are in the `test/src` directories. For example: +``` +test# ls src/msort +msort-fip.kk msort-std.kk +``` + +The main implementation of the FIP check can be found in +`koka/src/Core/CheckFBIP.hs`, while the main Perceus +reuse analysis is in `koka/src/Backend/C/ParcReuse.hs`. + + +## Re-build the Benchmarks + +All tests can be recompiled using: +``` +test# ./bench.sh allb build +``` + +Further options: + +* `allb`: all benchmarks (also `allkk` and `allc` to select a subset, or `rbtree`, `msort`, `qsort`, `ftree`, and `tmap`). +* `build`: build benchmarks. +* `run`: run benchmarks and show benchmark scores (calculating median and stddev). +* `-n=<`N`>`: run each benchmark N times. +* `koka=`: set koka compiler command explicitly. +* `ccomp=`: set C compiler, either `clang` or `gcc` (or `gcc-`). + +The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. + + +## Expected Results + +These were obtained running on Ubuntu 22.0.4 on a 16-core AMD 7950X @ 4.5Ghz. + +``` +test# ./bench allb build run -n=10 +... +``` + +``` +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.59 1.000 .0057735 6944 +kk rbtree fip-icfp 100000 0.53 .898 .0051846 6916 +kk rbtree std-reuse 100000 0.61 1.033 .0059640 6900 +kk rbtree std 100000 1.48 2.508 .1023885 6936 +kk rbtree fip-clrs 100000 0.78 1.322 .0076325 6940 +c rbtree clrs 100000 0.68 1.152 .0066510 6368 +c rbtree clrs-mi 100000 0.57 .966 0 7944 +c rbtree clrs-full 100000 0.67 1.135 .0065529 6404 +c rbtree clrs-full-mi 100000 0.57 .966 0 7948 +cpp rbtree stl 100000 0.88 1.491 .0086082 8440 +cpp rbtree stl-mi 100000 0.58 .983 0 10168 +## +kk ftree fip 100000 0.83 1.000 .0057735 7036 +kk ftree std-reuse 100000 0.90 1.084 .075101 6912 +kk ftree std 100000 1.32 1.590 .0091798 6808 +## +kk msort fip 100000 0.92 1.000 .0057735 9064 +kk msort std-reuse 100000 0.90 .978 .0056464 11588 +kk msort std 100000 1.17 1.271 .01037767 11552 +## +kk qsort fip 100000 1.13 1.000 .0057735 14588 +kk qsort std-reuse 100000 1.48 1.309 .0226725 15140 +kk qsort std 100000 2.13 1.884 .0543863 15116 +## +kk tmap fip 100000 1.13 1.000 .0238048 11144 +kk tmap std-reuse 100000 0.80 .707 .00577263 11016 +kk tmap std 100000 0.82 .725 .0041857 11152 +c tmap fip 100000 1.36 1.203 .0208365 7968 +c tmap fip-mi 100000 0.59 .522 .0030137 9992 +c tmap std 100000 1.44 1.274 .0073554 7912 +c tmap std-mi 100000 0.63 .557 .0032158 9952 +``` + + +# Building from Scratch + +These are instructions to re-create the image on a Unix system. + +Basics: + +``` +sudo apt update +sudo apt ugrade +sudo apt-get install -y --no-install-recommends ca-certificates +sudo apt-get install -y --no-install-recommends libc-dev build-essential time bc +sudo apt-get install -y --no-install-recommends tar cmake curl +sudo apt-get install -y --no-install-recommends gcc clang +``` + +Stack: + +``` +curl -sSL https://get.haskellstack.org | sh +``` + +Mimalloc: + +``` +git clone https://github.com/microsoft/mimalloc -b v2.1.1 +cd mimalloc +mkdir -p out/release +cd out/release +cmake ../.. +make +sudo make install +cd ~ +``` + +Koka, commit 54a16a5 + +``` +git clone --recursive https://github.com/koka-lang/koka -b dev-fbip +cd koka +git checkout 54a16a5 +stack build --fast +``` + +And go to the test directory to build and run a benchmark: + +``` +cd ~/koka/test/fip +./bench.sh rbtree build run +``` From 4135cb7f6c68ef319bb09e56dc6959b1648fd2ad Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 2 Jun 2023 19:37:47 -0700 Subject: [PATCH 205/233] add --fallocstats flag; avoid allocation in sfc-step for random --- kklib/ide/vs2022/kklib.vcxproj | 4 ++-- kklib/include/kklib.h | 2 +- kklib/src/integer.c | 2 +- lib/std/num/random.kk | 20 +++++++++++--------- src/Compiler/Options.hs | 6 ++++++ 5 files changed, 21 insertions(+), 13 deletions(-) diff --git a/kklib/ide/vs2022/kklib.vcxproj b/kklib/ide/vs2022/kklib.vcxproj index 1006e9062..ae248b443 100644 --- a/kklib/ide/vs2022/kklib.vcxproj +++ b/kklib/ide/vs2022/kklib.vcxproj @@ -97,7 +97,7 @@ true true ../../include;../../mimalloc/include - KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + KK_DEBUG=1;KK_STAT=2;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); CompileAsCpp false stdcpp17 @@ -117,7 +117,7 @@ true true ../../include;../../mimalloc/include - KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + KK_DEBUG=1;KK_STAT=2;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); true stdcpp17 EditAndContinue diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 3a37543eb..3d3602a07 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 107 // modify on changes to trigger recompilation +#define KKLIB_BUILD 108 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/src/integer.c b/kklib/src/integer.c index a6f22c4f5..fd94c8893 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -223,7 +223,7 @@ static kk_bigint_t* bigint_alloc(kk_ssize_t count, bool is_neg, kk_context_t* ct b->count = count; return b; } - + static kk_bigint_t* bigint_alloc_zero(kk_ssize_t count, bool is_neg, kk_context_t* ctx) { kk_bigint_t* b = bigint_alloc(count, is_neg, ctx); kk_memset(b->digits, 0, kk_ssizeof(kk_digit_t)* bigint_available_(b)); diff --git a/lib/std/num/random.kk b/lib/std/num/random.kk index e2b738ed2..756b3dc2c 100644 --- a/lib/std/num/random.kk +++ b/lib/std/num/random.kk @@ -41,18 +41,20 @@ pub fun strong-random(action : () -> a) : a // abstract value struct sfc(x:int32, y:int32, z:int32, cnt:int32) -pub fun sfc-step( sfc : sfc ) : (int32,sfc) +pub value struct sfc-result( rnd : int32, state : sfc ) + +pub fun sfc-step( sfc : sfc ) : sfc-result match sfc Sfc(x,y,z,cnt) -> val res = x + y + cnt - (res, Sfc( y ^ shr(y,9), - z + shl(z,3), - rotl(z,21) + res, - cnt + 1.int32 )) + Sfc-result( res, Sfc( y ^ shr(y,9), + z + shl(z,3), + rotl(z,21) + res, + cnt + 1.int32 )) pub fun sfc-init32( seed1 : int32, seed2 : int32 ) : sfc val sfc0 = Sfc(0.int32, seed1, seed2, 1.int32) - fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).snd } ) // step 12 times + fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).state } ) // step 12 times pub fun sfc-init( seed : int ) : sfc @@ -70,9 +72,9 @@ pub fun sfc-init( seed : int ) : sfc pub fun pseudo-random( seed : int, action : () -> a) : e a var s := sfc-init(seed) with fun random-int32() - val (x,sfc) = sfc-step(s) - s := sfc - x + val sfc = sfc-step(s) + s := sfc.state + sfc.rnd action() diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index 22175fb37..94b3c0093 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -185,6 +185,7 @@ data Flags , asan :: Bool , useStdAlloc :: Bool -- don't use mimalloc for better asan and valgrind support , optSpecialize :: Bool + , mimallocStats :: Bool } flagsNull :: Flags @@ -280,6 +281,7 @@ flagsNull False -- use asan False -- use stdalloc True -- use specialization (only used if optimization level >= 1) + False -- use mimalloc stats isHelp Help = True isHelp _ = False @@ -371,6 +373,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip -- hidden , hide $ fflag ["asan"] (\b f -> f{asan=b}) "compile with address, undefined, and leak sanitizer" , hide $ fflag ["stdalloc"] (\b f -> f{useStdAlloc=b}) "use the standard libc allocator" + , hide $ fflag ["allocstats"] (\b f -> f{mimallocStats=b}) "enable mimalloc statitistics" , hide $ fnum 3 "n" ["simplify"] (\i f -> f{simplify=i}) "enable 'n' core simplification passes" , hide $ fnum 10 "n" ["maxdup"] (\i f -> f{simplifyMaxDup=i}) "set 'n' as maximum code duplication threshold" , hide $ fnum 10 "n" ["inline"] (\i f -> f{optInlineMax=i}) "set 'n' as maximum inline threshold (=10)" @@ -668,6 +671,7 @@ processOptions flags0 opts ++ (if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")]) ++ (if optctailCtxPath flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")]) ++ (if platformHasCompressedFields (platform flags) then [("KK_INTB_SIZE",show (sizeField (platform flags)))] else []) + ++ (if not stdAlloc && mimallocStats flags then [("MI_STAT","2")] else []) -- vcpkg -- (vcpkgRoot,vcpkg) <- vcpkgFindRoot (vcpkgRoot flags) @@ -1108,6 +1112,8 @@ ccFromPath flags path ,True) else if (useStdAlloc flags) then return (cc{ ccName = ccName cc ++ "-stdalloc" }, False) + else if (mimallocStats flags) + then return (cc{ ccName = ccName cc ++ "-allocstats" }, False) else return (cc,False) ccCheckExist :: CC -> IO () From e2a6f60e6495a7966679f9c3c5b7ce0ac4e2b906 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 2 Jun 2023 20:25:52 -0700 Subject: [PATCH 206/233] always prefer OVF for int arithmetic --- kklib/ide/vs2022/kklib-test-interactive.vcxproj | 2 +- kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters | 2 +- kklib/include/kklib.h | 2 +- kklib/include/kklib/integer.h | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index e4052265c..fbf85e438 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,7 +165,7 @@ - + diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index 812840709..9d8c99a1b 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -6,7 +6,6 @@ - @@ -14,6 +13,7 @@ + diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 3d3602a07..d54e7a3f4 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 108 // modify on changes to trigger recompilation +#define KKLIB_BUILD 110 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 7502291b5..858dddac8 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -156,7 +156,7 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. #define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits #ifndef KK_INT_ARITHMETIC -#if (KK_INTF_SIZE <= 4) && defined(__GNUC__) +#if defined(__GNUC__) // (KK_INTF_SIZE <= 4) #define KK_INT_ARITHMETIC KK_INT_USE_OVF #else #define KK_INT_ARITHMETIC KK_INT_USE_SOFA From fe1ed37bee048ef8d04b88721a06c4383c6cf3b0 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 3 Jun 2023 08:11:12 -0700 Subject: [PATCH 207/233] rename random state to rstate --- lib/std/num/random.kk | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/std/num/random.kk b/lib/std/num/random.kk index 756b3dc2c..046478239 100644 --- a/lib/std/num/random.kk +++ b/lib/std/num/random.kk @@ -41,7 +41,7 @@ pub fun strong-random(action : () -> a) : a // abstract value struct sfc(x:int32, y:int32, z:int32, cnt:int32) -pub value struct sfc-result( rnd : int32, state : sfc ) +pub value struct sfc-result( rnd : int32, rstate : sfc ) pub fun sfc-step( sfc : sfc ) : sfc-result match sfc @@ -54,7 +54,7 @@ pub fun sfc-step( sfc : sfc ) : sfc-result pub fun sfc-init32( seed1 : int32, seed2 : int32 ) : sfc val sfc0 = Sfc(0.int32, seed1, seed2, 1.int32) - fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).state } ) // step 12 times + fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).rstate } ) // step 12 times pub fun sfc-init( seed : int ) : sfc @@ -73,7 +73,7 @@ pub fun pseudo-random( seed : int, action : () -> a) : e a var s := sfc-init(seed) with fun random-int32() val sfc = sfc-step(s) - s := sfc.state + s := sfc.rstate sfc.rnd action() From 38bc14a1fd2a9086c9a5b390ccb3efa9695e9039 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 3 Jun 2023 18:07:47 -0700 Subject: [PATCH 208/233] some improvements to fip warnings --- lib/std/core.kk | 28 ++++++++++++++-------------- lib/std/core/types.kk | 24 +++++++++++++++--------- src/Core/CheckFBIP.hs | 12 +++++++++--- 3 files changed, 38 insertions(+), 26 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index 94c96105b..3804f221c 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -804,79 +804,79 @@ pub fun maybe( b : bool ) : maybe<()> // ---------------------------------------------------------------------------- // Compare two integers -pub inline extern compare(^x : int, ^y : int) : order +pub inline fip extern compare(^x : int, ^y : int) : order c inline "kk_int_as_order(kk_integer_cmp_borrow(#1,#2,kk_context()),kk_context())" cs "Primitive.IntCompare" js "$std_core._int_compare" // Are two integers equal? -pub inline extern (==)(^x : int, ^y : int) : bool +pub inline fip extern (==)(^x : int, ^y : int) : bool c "kk_integer_eq_borrow" cs inline "(#1 == #2)" js "$std_core._int_eq" // Are two integers not equal? -pub inline extern (!=)(^x : int, ^y : int) : bool +pub inline fip extern (!=)(^x : int, ^y : int) : bool c "kk_integer_neq_borrow" cs inline "(#1 != #2)" js "$std_core._int_ne" // Is the first integer smaller or equal to the second? -pub inline extern (<=)(^x : int, ^y : int) : bool +pub inline fip extern (<=)(^x : int, ^y : int) : bool c "kk_integer_lte_borrow" cs inline "(#1 <= #2)" js "$std_core._int_le" // Is the first integer greater or equal to the second? -pub inline extern (>=)(^x : int, ^y : int) : bool +pub inline fip extern (>=)(^x : int, ^y : int) : bool c "kk_integer_gte_borrow" cs inline "(#1 >= #2)" js "$std_core._int_ge" // Is the first integer smaller than the second? -pub inline extern (<)(^x : int, ^y : int) : bool +pub inline fip extern (<)(^x : int, ^y : int) : bool c "kk_integer_lt_borrow" cs inline "(#1 < #2)" js "$std_core._int_lt" // Is the first integer greater than the second? -pub inline extern (>)(^x : int, ^y : int) : bool +pub inline fip extern (>)(^x : int, ^y : int) : bool c "kk_integer_gt_borrow" cs inline "(#1 > #2)" js "$std_core._int_gt" -inline extern int-add : (int,int) -> int +inline fip extern int-add : (int,int) -> int c "kk_integer_add" cs inline "(#1 + #2)" js "$std_core._int_add" // Add two integers. -pub fun (+)(x : int, y : int ) : int +pub fip fun (+)(x : int, y : int ) : int int-add(x,y) -inline extern int-sub : (int,int) -> int +inline fip extern int-sub : (int,int) -> int c "kk_integer_sub" cs inline "(#1 - #2)" js "$std_core._int_sub" // Substract two integers. -pub fun (-)(x : int, y : int ) : int +pub fip fun (-)(x : int, y : int ) : int int-sub(x,y) // Multiply two integers. -pub inline extern (*) : (int,int) -> int +pub inline fip extern (*) : (int,int) -> int c "kk_integer_mul" cs inline "(#1 * #2)" js "$std_core._int_mul" // Euclidean-0 division of two integers. See also `divmod:(x : int, y : int) -> (int,int)`. -pub inline extern (/)(x:int,y:int) : int +pub inline fip extern (/)(x:int,y:int) : int c "kk_integer_div" cs "Primitive.IntDiv" js "$std_core._int_div" // Euclidean modulus of two integers; always a non-negative number. See also `divmod:(x : int, y : int) -> (int,int)`. -pub inline extern (%) : (int,int) -> int +pub inline fip extern (%) : (int,int) -> int c "kk_integer_mod" cs "Primitive.IntMod" js "$std_core._int_mod" diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index dfa6c7422..0d3a7ed27 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -15,6 +15,7 @@ */ module std/core/types +pub infix 65 (++.) pub infixr 60 (++) pub infixr 30 (&&) pub infixr 20 (||) @@ -385,38 +386,43 @@ abstract value type cctx // First-class constructor context. pub alias ctx = cctx -// _Internal_. Create a hole for a context -pub extern ".cctx-hole-create"() : a +// _Internal_. Create a hole for a context +pub inline fip extern ".cctx-hole-create"() : a c inline "kk_intf_box(0)" js inline "undefined" // _Internal_. Create an initial non-empty context. -pub extern ".cctx-create"( x : a, xhole : field-addr ) : cctx +pub inline fip extern ".cctx-create"( x : a, xhole : field-addr ) : cctx c "kk_cctx_create" js "_cctx_create" // _Internal_. Extend a constructor context with a non-empty context -pub inline extern ".cctx-extend"( c : cctx, x : b, xhole : field-addr ) : cctx +pub inline fip extern ".cctx-extend"( c : cctx, x : b, xhole : field-addr ) : cctx c inline "kk_cctx_extend(#1,#2,#3,false /*is-linear*/,kk_context())" js "_cctx_extend" // _Internal_. Compose a constructor context with a non-empty context -pub inline extern ".cctx-compose-extend"( c1 : cctx, c2 : cctx ) : cctx +pub inline fip extern ".cctx-compose-extend"( c1 : cctx, c2 : cctx ) : cctx c inline "kk_cctx_extend(#1,#2.res,#2.holeptr,false /*is-linear*/,kk_context())" js "_cctx_compose" // Apply a constructor context -pub inline extern []( c : cctx, x : b ) : a +pub inline fip extern []( c : cctx, x : b ) : a + c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_apply" + +// Apply a constructor context. +pub inline fip extern (++.)( c : cctx, x : b ) : a c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" js "_cctx_apply" // Compose two constructor contexts. -pub inline extern (++)( c1 : cctx, c2 : cctx ) : cctx - c inline "kk_cctx_compose(#1,#2,false /* is-linear */,kk_context())" +pub inline fip extern (++)( c1 : cctx, c2 : cctx ) : cctx + c inline "kk_cctx_compose(#1,#2,false /*is-linear*/,kk_context())" js "_cctx_compose" // Create an empty context -pub inline extern cctx-empty() : cctx +pub inline fip extern cctx-empty() : cctx c "kk_cctx_empty" js "_cctx_empty" diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 6a6cb81a4..64c2396fd 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -38,7 +38,8 @@ import qualified Core.Core as Core import Core.Pretty import Core.CoreVar import Core.Borrowed -import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue) +import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue, + nameCCtxSetCtxPath, nameFieldAddrOf) import Backend.C.ParcReuse (getFixedDataAllocSize) import Backend.C.Parc (getDataDef') import Data.Ratio @@ -114,6 +115,8 @@ chkExpr expr out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out pars + App (TypeApp (Var tname _) _) _ | getName tname `elem` [nameCCtxSetCtxPath] -> return () + App fn args -> chkApp fn args Var tname info -> markSeen tname info @@ -239,8 +242,9 @@ chkLit lit LitInt _ -> pure () -- we do not care about allocating big integers LitFloat _ -> pure () LitChar _ -> pure () - LitString _ -> requireCapability mayAlloc $ \ppenv -> Just $ - text "Inline string literals are allocated. Consider lifting to toplevel to avoid this." + LitString _ -> pure () + -- requireCapability mayAlloc $ \ppenv -> Just $ + -- text "Inline string literals are allocated. Consider lifting to toplevel to avoid this." chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info @@ -406,6 +410,8 @@ chkFunCallable fn = do fip <- getFip g <- gamma <$> getEnv case getFipInfo (gammaLookupCanonical fn g) of + Nothing | fn `elem` [nameCCtxSetCtxPath,nameFieldAddrOf] + -> writeCallAllocation fn (Fip (AllocAtMost 0)) Nothing -> emitWarning $ text $ "FIP analysis couldn't find FIP information for function: " ++ show fn From b6067e75235bd5e6625ce4d0288134f5efc3280c Mon Sep 17 00:00:00 2001 From: daanx Date: Tue, 13 Jun 2023 18:02:23 -0700 Subject: [PATCH 209/233] fix bug in tail call parameter assignment in C --- .../ide/vs2022/kklib-test-interactive.vcxproj | 4 +-- .../kklib-test-interactive.vcxproj.filters | 4 +-- src/Backend/C/FromCore.hs | 25 ++++++++++++------- test/bench/haskell/rbtree.hs | 2 +- 4 files changed, 21 insertions(+), 14 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index fbf85e438..921dcde8f 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,8 +165,8 @@ - - + + diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index 9d8c99a1b..f30bf044f 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -5,7 +5,6 @@ - @@ -13,7 +12,8 @@ - + + diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index d768dda11..a83b2df0d 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1384,16 +1384,20 @@ tryTailCall result expr = fmap (debugWrap "genOverride") $ do (stmts, varNames) <- do -- args' <- mapM tailCallArg args let args' = args - bs <- mapM genVarBinding args' + bs <- mapM (genTailVarBinding params) (zip params args') return (unzip bs) docs1 <- mapM genDefName params docs2 <- mapM genDefName varNames let assigns = map (\(p,a)-> if p == a then debugComment ("genOverride: skipped overriding `" ++ (show p) ++ "` with itself") - else debugComment ("genOverride: preparing tailcall") <.> p <+> text "=" <+> a <.> semi + else p <+> text "=" <+> a <.> semi ) (zip docs1 docs2) return $ vcat (stmts ++ assigns) + genTailVarBinding params (param,expr) + = case expr of + Var tn _ | tn /= param && tn `elem` params -> genVarBindingAlways expr + _ -> genVarBinding expr -- | Generates a statement from an expression by applying a return context (deeply) inside genStat :: Result -> Expr -> Asm Doc @@ -1758,13 +1762,16 @@ genVarBinding :: Expr -> Asm (Doc, TName) genVarBinding expr = case expr of Var tn _ | not (isQualified (getName tn))-> return $ (empty, tn) - _ -> do name <- newVarName "x" - let tp = typeOf expr - tname = TName name tp - doc <- genStat (ResultAssign tname Nothing) expr - if (dstartsWith doc (show (ppName name) ++ " =")) - then return (ppType tp <+> doc, tname) - else return (ppVarDecl tname <.> unitSemi tp <-> doc, tname) + _ -> genVarBindingAlways expr + +genVarBindingAlways expr + = do name <- newVarName "x" + let tp = typeOf expr + tname = TName name tp + doc <- genStat (ResultAssign tname Nothing) expr + if (dstartsWith doc (show (ppName name) ++ " =")) + then return (ppType tp <+> doc, tname) + else return (ppVarDecl tname <.> unitSemi tp <-> doc, tname) --------------------------------------------------------------------------------- diff --git a/test/bench/haskell/rbtree.hs b/test/bench/haskell/rbtree.hs index 0aa16085d..0bcf75b34 100644 --- a/test/bench/haskell/rbtree.hs +++ b/test/bench/haskell/rbtree.hs @@ -36,7 +36,7 @@ ins Leaf kx vx = Node Red Leaf kx vx Leaf ins (Node Red a ky vy b) kx vx = (if lt kx ky then Node Red (ins a kx vx) ky vy b else if lt ky kx then Node Red a ky vy (ins b kx vx) - else Node Red a ky vy (ins b kx vx)) + else Node Red a kx vx b -- Node Red a ky vy (ins b kx vx)) ins (Node Black a ky vy b) kx vx = if lt kx ky then (if is_red a then balance1 (Node Black Leaf ky vy b) (ins a kx vx) From 2def6f8e502e88596a919ddcdec505c2ebbcfc28 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 09:34:16 -0700 Subject: [PATCH 210/233] fix duplicate warnings --- kklib/ide/vs2022/kklib-test-interactive.vcxproj | 4 ++-- kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters | 4 ++-- lib/std/core/types.kk | 2 +- src/Backend/C/FromCore.hs | 2 +- src/Common/Error.hs | 6 +++++- src/Compiler/Compile.hs | 2 +- 6 files changed, 12 insertions(+), 8 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index 921dcde8f..6dcac046f 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -165,8 +165,6 @@ - - @@ -177,6 +175,8 @@ + + diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index f30bf044f..fe2b9b97c 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -12,8 +12,8 @@ - - + + diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 0d3a7ed27..8ed6c763e 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -15,7 +15,7 @@ */ module std/core/types -pub infix 65 (++.) +pub infixr 65 (++.) pub infixr 60 (++) pub infixr 30 (&&) pub infixr 20 (||) diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index a83b2df0d..c28daeea5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -2585,7 +2585,7 @@ ppModName name encode :: Bool -> Name -> Doc encode isModule name = let s = asciiEncode isModule (show name) - in if (isReserved s) + in if (isReserved s || s == "" || isDigit (head s)) then text ("kkloc_" ++ s) else text s diff --git a/src/Common/Error.hs b/src/Common/Error.hs index ba32e5397..324ceba2e 100644 --- a/src/Common/Error.hs +++ b/src/Common/Error.hs @@ -10,7 +10,7 @@ -} ----------------------------------------------------------------------------- module Common.Error( Error, ErrorMessage(..), errorMsg, ok - , catchError, checkError, warningMsg, addWarnings + , catchError, checkError, warningMsg, addWarnings, ignoreWarnings , ppErrorMessage, errorWarning ) where import Control.Monad @@ -91,6 +91,10 @@ errorMerge err1 err2 unwarn (ErrorWarning warnings msg) = (warnings, msg) unwarn msg = ([],msg) +ignoreWarnings :: Error a -> Error a +ignoreWarnings (Error (ErrorWarning _ err) _) = Error err [] +ignoreWarnings (Error err _) = Error err [] +ignoreWarnings (Ok x _) = Ok x [] {-------------------------------------------------------------------------- pretty diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index c65242365..660068352 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -457,7 +457,7 @@ compileProgram' term flags modules compileTarget fname program ) False r) [] r defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (defFun []) InlineNever "" program2 = programAddDefs program [] [defMain] - in do (loaded3,_) <- typeCheck loaded1 flags 0 coreImports program2 + in do (loaded3,_) <- ignoreWarnings $ typeCheck loaded1 flags 0 coreImports program2 return (Executable mainName2 tp, loaded3) -- TODO: refine the type of main2 [info] -> errorMsg (ErrorGeneral (infoRange info) (text "'main' must be declared as a function (fun)")) From ad55751b013dbc5bc593e4ef6fd6500649592ad6 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 09:50:16 -0700 Subject: [PATCH 211/233] do not count int as an allocated type --- src/Backend/C/Parc.hs | 2 +- src/Core/CheckFBIP.hs | 27 +++++++++++++++------------ 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index b9bad8058..4d77b1059 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -20,7 +20,7 @@ Notes: the same in a scope. ----------------------------------------------------------------------------} -module Backend.C.Parc ( parcCore, getDataDef' ) where +module Backend.C.Parc ( parcCore, getDataDef', getDataInfo' ) where import Lib.Trace (trace) import Control.Monad diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 64c2396fd..c66e45586 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -39,9 +39,9 @@ import Core.Pretty import Core.CoreVar import Core.Borrowed import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue, - nameCCtxSetCtxPath, nameFieldAddrOf) + nameCCtxSetCtxPath, nameFieldAddrOf, nameTpInt) import Backend.C.ParcReuse (getFixedDataAllocSize) -import Backend.C.Parc (getDataDef') +import Backend.C.Parc (getDataInfo') import Data.Ratio import Data.Ord (Down (Down)) import Control.Monad.Reader @@ -662,17 +662,20 @@ zipParamInfo xs = zip (xs ++ repeat Own) -- value types with reference fields still need a drop needsDupDrop :: Type -> Chk Bool needsDupDrop tp - = do dd <- getDataDef tp - return $ case dd of - (DataDefValue vrepr) | valueReprIsRaw vrepr -> False - _ -> True - -getDataDef :: Type -> Chk DataDef -getDataDef tp + = do mbdi <- getDataInfo tp + return $ + case mbdi of + Nothing -> True + Just di -> case dataInfoDef di of + DataDefValue vrepr | valueReprIsRaw vrepr -> False + _ -> if dataInfoName di == nameTpInt + then False + else True + +getDataInfo :: Type -> Chk (Maybe DataInfo) +getDataInfo tp = do newtypes <- getNewtypes - return (case getDataDef' newtypes tp of - Just dd -> dd - Nothing -> DataDefNormal) + return (getDataInfo' newtypes tp) getNewtypes :: Chk Newtypes getNewtypes = newtypes <$> getEnv From 566d924c9cdf65688145940ca32d05038f56c267 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 10:00:42 -0700 Subject: [PATCH 212/233] fix warnings for .cctx --- src/Common/Name.hs | 6 +++++- src/Core/CheckFBIP.hs | 22 ++++++++++++---------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 7be558699..642036d12 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -24,7 +24,7 @@ module Common.Name , qualify, unqualify, isQualified, qualifier , nameId, nameModule - , newPaddingName, isPaddingName + , newPaddingName, isPaddingName, isCCtxName , newFieldName, isFieldName, isWildcard , newHiddenExternalName, isHiddenExternalName , newHiddenName, isHiddenName, hiddenNameStartsWith @@ -330,6 +330,10 @@ isPaddingName name = -- hiddenNameStartsWith name "padding" nameId name `startsWith` (".padding") +isCCtxName name + = -- hiddenNameStartsWith name "padding" + nameId name `startsWith` (".cctx") + newFieldName i = newHiddenName ("field" ++ show i) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index c66e45586..51d1055a2 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -487,8 +487,8 @@ isBorrowed nm pure $ getName nm `S.member` delta st markSeen :: TName -> VarInfo -> Chk () -markSeen tname info | infoIsRefCounted info -- is locally defined? - = do isHeapValue <- needsDupDrop (tnameType tname) +markSeen tname info | infoIsRefCounted info -- is locally defined? + = do isHeapValue <- needsDupDrop tname when isHeapValue $ writeOutput (Output (M.singleton tname 1) M.empty Leaf) markSeen tname info = chkWrap tname info -- wrap rule @@ -498,7 +498,7 @@ markBorrowed nm info = do b <- isBorrowed nm unless b $ do markSeen nm info - isHeapValue <- needsDupDrop (tnameType nm) + isHeapValue <- needsDupDrop nm when (isHeapValue && infoIsRefCounted info) $ requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] @@ -544,7 +544,7 @@ joinContexts pats cs tryReuse (allReusable, out) tname = do mOut <- tryDropReuse tname out - isHeapVal <- needsDupDrop (tnameType tname) + isHeapVal <- needsDupDrop tname pure $ case mOut of Nothing -> (allReusable && not isHeapVal, out) Just out -> (allReusable, out) @@ -575,13 +575,13 @@ bindName nm msize out (Just sz, _) -> provideToken nm sz out (_, Just out) -> pure out (Nothing, Nothing) -> do - isHeapValue <- needsDupDrop (tnameType nm) + isHeapValue <- needsDupDrop nm when isHeapValue $ requireCapability mayDealloc $ \ppenv -> Just $ cat [text "Variable unused: ", ppName ppenv (getName nm)] pure out Just n - -> do isHeapVal <- needsDupDrop (tnameType nm) + -> do isHeapVal <- needsDupDrop nm when (n > 1 && isHeapVal) $ requireCapability mayAlloc $ \ppenv -> Just $ cat [text "Variable used multiple times: ", ppName ppenv (getName nm)] @@ -660,15 +660,17 @@ zipParamInfo :: [ParamInfo] -> [b] -> [(ParamInfo, b)] zipParamInfo xs = zip (xs ++ repeat Own) -- value types with reference fields still need a drop -needsDupDrop :: Type -> Chk Bool -needsDupDrop tp - = do mbdi <- getDataInfo tp +needsDupDrop :: TName -> Chk Bool +needsDupDrop tname | isCCtxName (getName tname) = return False -- ignore generated contexts +needsDupDrop tname + = do let tp = tnameType tname + mbdi <- getDataInfo tp return $ case mbdi of Nothing -> True Just di -> case dataInfoDef di of DataDefValue vrepr | valueReprIsRaw vrepr -> False - _ -> if dataInfoName di == nameTpInt + _ -> if dataInfoName di == nameTpInt -- ignore special types (just `int` for now) then False else True From af524179d1416d35ce757a00ba92bcbb96749ed8 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 10:30:58 -0700 Subject: [PATCH 213/233] add line numbers and pretty printing to fip warnings --- src/Core/CheckFBIP.hs | 55 +++++++++++++++++++++++-------------------- src/Core/Pretty.hs | 5 +++- src/Type/Type.hs | 2 +- 3 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 51d1055a2..31d6ed1d2 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -57,8 +57,8 @@ checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> Gamma -> CorePha checkFBIP penv platform newtypes borrowed gamma = do uniq <- unique defGroups <- getCoreDefs - let (_,docs) = runChk penv uniq platform newtypes borrowed gamma (chkDefGroups defGroups) - mapM_ (\doc -> liftError (warningMsg (rangeNull, doc))) docs + let (_,warns) = runChk penv uniq platform newtypes borrowed gamma (chkDefGroups defGroups) + mapM_ (\warn -> liftError (warningMsg warn)) warns {-------------------------------------------------------------------------- @@ -128,7 +128,7 @@ chkExpr expr withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ withTailMod [Let dgs body] $ chkExpr $ defExpr def Let _ _ - -> emitWarning $ text "FIP check can not handle nested function bindings." + -> emitWarning $ \penv -> text "FIP check can not handle nested function bindings." Case scrutinees branches -> chkBranches scrutinees branches @@ -197,6 +197,8 @@ bindPattern (PatVar tname pat) out -- Else, don't bind the name. bindPattern (PatLit _) out = pure out bindPattern PatWild out = pure out + + chkApp :: Expr -> [Expr] -> Chk () chkApp (TypeLam _ fn) args = chkApp fn args -- ignore type machinery chkApp (TypeApp fn _) args = chkApp fn args @@ -220,7 +222,7 @@ chkApp fn args -- local function _ -> pure False unless isBapp $ do requireCapability mayDealloc $ \ppenv -> Just $ - cat [text "Owned calls to functions require deallocation: ", prettyExpr ppenv fn ] + vcat [text "Owned calls to functions require deallocation: ", source ppenv (prettyExpr ppenv fn) ] chkExpr fn chkArg :: (ParamInfo, Expr) -> Chk () @@ -234,7 +236,7 @@ chkArg (Borrow, expr) (Var tname info) -> markBorrowed tname info _ -> do chkExpr expr requireCapability mayDealloc $ \ppenv -> Just $ - text $ "Passing owned expressions as borrowed requires deallocation: " ++ show expr + vcat [text "Passing owned expressions as borrowed requires deallocation:", source ppenv (prettyExpr ppenv expr)] chkLit :: Lit -> Chk () chkLit lit @@ -250,7 +252,7 @@ chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - emitWarning $ text "A function with borrowed parameters is passed as an argument and implicitly wrapped." + emitWarning $ \penv -> text "A function with borrowed parameters is passed as an argument and implicitly wrapped." chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () @@ -266,7 +268,7 @@ chkAllocation cname crepr chkEffect :: Tau -> Chk () chkEffect tp = if isFBIPExtend tp then pure () else - emitWarning $ text "Algebraic effects other than are not FIP/FBIP." + emitWarning $ \penv -> text "Algebraic effects other than" <+> ppType penv typePure <+> text "are not FIP/FBIP." where isFBIPExtend tp = case extractEffectExtend tp of (taus, tau) -> all isFBIP taus @@ -278,7 +280,7 @@ chkEffect tp {-------------------------------------------------------------------------- Chk monad --------------------------------------------------------------------------} -type Chk a = ReaderT (Env, Input) (WriterT (Output, [Doc]) Unique) a +type Chk a = ReaderT (Env, Input) (WriterT (Output, [(Range,Doc)]) Unique) a data Env = Env{ currentDef :: [Def], prettyEnv :: Pretty.Env, @@ -331,7 +333,7 @@ prettyGammaDia ppenv (Output nm dia _) (\(sz, cs) -> map (\(_, (c,_):_) -> prettyCon ppenv c sz) cs) (M.toList dia) -runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[Doc]) +runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[(Range,Doc)]) runChk penv u platform newtypes borrowed gamma c = fst $ runUnique 0 $ fmap (fmap snd) $ runWriterT $ @@ -413,11 +415,10 @@ chkFunCallable fn Nothing | fn `elem` [nameCCtxSetCtxPath,nameFieldAddrOf] -> writeCallAllocation fn (Fip (AllocAtMost 0)) Nothing - -> emitWarning $ text $ - "FIP analysis couldn't find FIP information for function: " ++ show fn + -> emitWarning $ \penv -> text "FIP analysis couldn't find FIP information for function:" <+> ppName penv fn Just fip' -> if fip' `isCallableFrom` fip then writeCallAllocation fn fip' - else emitWarning $ text $ "Non-FIP function called: " ++ show fn + else emitWarning $ \penv -> text "Non-FIP function called:" <+> ppName penv fn -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output @@ -434,7 +435,7 @@ requireCapability mayUseCap test unless hasCap $ do env <- getEnv case test (prettyEnv env) of - Just warning -> emitWarning warning + Just warning -> emitWarning (\_ -> warning) Nothing -> pure () withNonTail :: Chk a -> Chk a @@ -634,7 +635,7 @@ checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ text $ "Unbound name (may have been used despite being borrowed): " ++ show nm + -> emitWarning $ \penv -> text "Unbound name (may have been used despite being borrowed):" <+> ppName penv (getName nm) let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations @@ -642,10 +643,10 @@ checkOutputEmpty out -- chkTrace $ show $ simplifyAllocTree (allocTree out) permission <- fipAlloc <$> getFip unless (allocations' <= permission) $ - emitWarning $ text $ "Function allocates " - ++ prettyFipAlloc allocations' - ++ " but was declared as allocating " - ++ prettyFipAlloc permission + emitWarning $ \penv -> text "Function allocates" + <+> text (prettyFipAlloc allocations') + <+> text "but was declared as allocating" + <+> text (prettyFipAlloc permission) simplifyAllocTree :: AllocTree -> AllocTree simplifyAllocTree (Seq a b) @@ -716,14 +717,18 @@ chkTrace msg = do env <- getEnv trace ("chk: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () -emitDoc :: Doc -> Chk () -emitDoc doc = tell (mempty, [doc]) +emitDoc :: Range -> Doc -> Chk () +emitDoc rng doc = tell (mempty, [(rng,doc)]) -emitWarning :: Doc -> Chk () -emitWarning doc - = do names <- currentDefNames - let fdoc = text (show names) <.> colon <+> doc - emitDoc fdoc +emitWarning :: (Pretty.Env -> Doc) -> Chk () +emitWarning makedoc + = do env <- getEnv + let (rng,name) = case currentDef env of + (def:_) -> (defNameRange def, defName def) + _ -> (rangeNull, nameNil) + penv = prettyEnv env + fdoc = ppName penv name <.> colon <+> makedoc penv + emitDoc rng fdoc getConstructorAllocSize :: ConRepr -> Chk Int getConstructorAllocSize conRepr diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index 0214a3c3c..a4f6e63ee 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -9,7 +9,7 @@ -} ----------------------------------------------------------------------------- -module Core.Pretty( prettyCore, prettyExpr, prettyPattern, prettyDef, prettyDefs, prettyDefGroup ) where +module Core.Pretty( prettyCore, prettyExpr, prettyPattern, prettyDef, prettyDefs, prettyDefGroup, keyword, source ) where import Lib.Trace import Data.Char( isAlphaNum ) @@ -38,6 +38,9 @@ prettyNames = True keyword env s = color (colorKeyword (colors env)) (text s) +source env doc + = color (colorSource (colors env)) doc + {-------------------------------------------------------------------------- Show instance declarations --------------------------------------------------------------------------} diff --git a/src/Type/Type.hs b/src/Type/Type.hs index 580f6a884..39a65c976 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -40,7 +40,7 @@ module Type.Type (-- * Types , orderEffect, labelName, labelNameFull, labelNameEx , isEffectEmpty, isEffectFixed, shallowEffectExtend, shallowExtractEffectExtend - , typeDivergent, typeTotal, typePartial + , typeDivergent, typeTotal, typePartial, typePure , typeList, typeVector, typeApp, typeRef, typeNull, typeOptional, typeMakeTuple , typeCCtx, typeCCtxx, typeFieldAddr , isOptional, makeOptional, unOptional From cffdb908a576df08be6ce5cb2612e6d26391e490 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 10:47:36 -0700 Subject: [PATCH 214/233] nicer fip error messages --- src/Core/CheckFBIP.hs | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 31d6ed1d2..baa9519f2 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -111,7 +111,7 @@ chkExpr expr Lam pars eff body -> do chkEffect eff requireCapability mayAlloc $ \ppenv -> Just $ - text "Lambdas are always allocated." + text "allocating a lambda expression" out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out pars @@ -128,7 +128,7 @@ chkExpr expr withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ withTailMod [Let dgs body] $ chkExpr $ defExpr def Let _ _ - -> emitWarning $ \penv -> text "FIP check can not handle nested function bindings." + -> emitWarning $ \penv -> text "internal: currently the fip analysis cannot handle nested function bindings" Case scrutinees branches -> chkBranches scrutinees branches @@ -214,7 +214,7 @@ chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function input <- getInput unless (isTailContext input || getName tname `notElem` defGroupNames input) $ requireCapability mayRecurse $ \ppenv -> Just $ - cat [text "Non-tail call to (mutually) recursive function: ", ppName ppenv (getName tname)] + cat [text "non-tail call to a (mutually) recursive function: ", ppName ppenv (getName tname)] chkApp fn args -- local function = do withNonTail $ mapM_ chkExpr args isBapp <- case fn of -- does the bapp rule apply? @@ -222,7 +222,7 @@ chkApp fn args -- local function _ -> pure False unless isBapp $ do requireCapability mayDealloc $ \ppenv -> Just $ - vcat [text "Owned calls to functions require deallocation: ", source ppenv (prettyExpr ppenv fn) ] + vcat [text "owned calls to functions require deallocation: ", source ppenv (prettyExpr ppenv fn) ] chkExpr fn chkArg :: (ParamInfo, Expr) -> Chk () @@ -236,7 +236,7 @@ chkArg (Borrow, expr) (Var tname info) -> markBorrowed tname info _ -> do chkExpr expr requireCapability mayDealloc $ \ppenv -> Just $ - vcat [text "Passing owned expressions as borrowed requires deallocation:", source ppenv (prettyExpr ppenv expr)] + vcat [text "passing owned expressions as borrowed causes deallocation:", source ppenv (prettyExpr ppenv expr)] chkLit :: Lit -> Chk () chkLit lit @@ -252,13 +252,13 @@ chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - emitWarning $ \penv -> text "A function with borrowed parameters is passed as an argument and implicitly wrapped." + emitWarning $ \penv -> text "a function with borrowed parameters is passed as an argument and implicitly wrapped (causing allocation)" chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () chkAllocation cname repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) = requireCapability mayAlloc $ \ppenv -> Just $ - cat [text "Types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] + cat [text "types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] chkAllocation cname crepr = do size <- getConstructorAllocSize crepr -- chkTrace $ "Allocation " ++ show cname ++ "/" ++ show size @@ -268,7 +268,7 @@ chkAllocation cname crepr chkEffect :: Tau -> Chk () chkEffect tp = if isFBIPExtend tp then pure () else - emitWarning $ \penv -> text "Algebraic effects other than" <+> ppType penv typePure <+> text "are not FIP/FBIP." + emitWarning $ \penv -> text "algebraic effects other than" <+> ppType penv typePure <+> text "may cause allocation." where isFBIPExtend tp = case extractEffectExtend tp of (taus, tau) -> all isFBIP taus @@ -325,7 +325,7 @@ prettyGammaNm ppenv (Output nm dia _) prettyCon :: Pretty.Env -> TName -> Int -> Doc prettyCon ppenv tname sz - = cat [ppName ppenv (getName tname), text "/", pretty (sz {-`div` 8-})] + = ppName ppenv (getName tname) <.> text "/" <.> pretty (sz {-`div` 8-}) prettyGammaDia :: Pretty.Env -> Output -> Doc prettyGammaDia ppenv (Output nm dia _) @@ -415,10 +415,10 @@ chkFunCallable fn Nothing | fn `elem` [nameCCtxSetCtxPath,nameFieldAddrOf] -> writeCallAllocation fn (Fip (AllocAtMost 0)) Nothing - -> emitWarning $ \penv -> text "FIP analysis couldn't find FIP information for function:" <+> ppName penv fn + -> emitWarning $ \penv -> text "internal: fip analysis could not find fip information for function:" <+> ppName penv fn Just fip' -> if fip' `isCallableFrom` fip then writeCallAllocation fn fip' - else emitWarning $ \penv -> text "Non-FIP function called:" <+> ppName penv fn + else emitWarning $ \penv -> text "calling a non-fip function:" <+> ppName penv fn -- | Run the given check, keep the warnings but extract the output. extractOutput :: Chk () -> Chk Output @@ -502,7 +502,7 @@ markBorrowed nm info isHeapValue <- needsDupDrop nm when (isHeapValue && infoIsRefCounted info) $ requireCapability mayDealloc $ \ppenv -> Just $ - cat [text "Last use of variable is borrowed: ", ppName ppenv (getName nm)] + text "the last use of" <+> ppName ppenv (getName nm) <+> text "is borrowed (causing deallocation)" getAllocation :: TName -> Int -> Chk () getAllocation nm 0 = pure () @@ -516,9 +516,9 @@ provideToken debugName size out = do requireCapability mayDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in case fittingAllocs of - [] -> Just $ cat [text "Unused reuse token provided by ", prettyCon ppenv debugName size] + [] -> Just $ text "the matched constructor" <+> prettyCon ppenv debugName size <+> text "is not reused" ((r, _):_) | r /= 1%1 -> - Just $ cat [text "Not all branches use reuse token provided by ", prettyCon ppenv debugName size] + Just $ text "not all branches can reuse the space provided by" <+> prettyCon ppenv debugName size _ -> Nothing pure $ out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } @@ -532,7 +532,7 @@ joinContexts pats cs pure (allReusable, c') unless (and noDealloc) $ do requireCapability mayDealloc $ \ppenv -> Just $ - vcat $ text "Not all branches use the same variables:" + vcat $ text "not all branches use the same variables:" : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs let unionDia = foldl1' (M.unionWith zipTokens) $ map (M.map (adjustProb (length cs')) . gammaDia) cs' pure (Output unionNm unionDia (Match (map allocTree cs'))) @@ -579,13 +579,13 @@ bindName nm msize out isHeapValue <- needsDupDrop nm when isHeapValue $ requireCapability mayDealloc $ \ppenv -> Just $ - cat [text "Variable unused: ", ppName ppenv (getName nm)] + text "the variable" <+> ppName ppenv (getName nm) <+> text "is unused (causing deallocation)" pure out Just n -> do isHeapVal <- needsDupDrop nm when (n > 1 && isHeapVal) $ requireCapability mayAlloc $ \ppenv -> Just $ - cat [text "Variable used multiple times: ", ppName ppenv (getName nm)] + text "the variable" <+> ppName ppenv (getName nm) <+> text "is used multiple times (causing sharing and preventing reuse)" pure out pure (out { gammaNm = M.delete nm (gammaNm out) }) @@ -635,7 +635,7 @@ checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ \penv -> text "Unbound name (may have been used despite being borrowed):" <+> ppName penv (getName nm) + -> emitWarning $ \penv -> text "unbound name (which may have been used despite being borrowed):" <+> ppName penv (getName nm) let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations @@ -643,7 +643,7 @@ checkOutputEmpty out -- chkTrace $ show $ simplifyAllocTree (allocTree out) permission <- fipAlloc <$> getFip unless (allocations' <= permission) $ - emitWarning $ \penv -> text "Function allocates" + emitWarning $ \penv -> text "function allocates" <+> text (prettyFipAlloc allocations') <+> text "but was declared as allocating" <+> text (prettyFipAlloc permission) @@ -727,7 +727,7 @@ emitWarning makedoc (def:_) -> (defNameRange def, defName def) _ -> (rangeNull, nameNil) penv = prettyEnv env - fdoc = ppName penv name <.> colon <+> makedoc penv + fdoc = text "fip fun" <+> ppName penv name <.> colon <+> makedoc penv emitDoc rng fdoc getConstructorAllocSize :: ConRepr -> Chk Int From 7ad0f8c4d1527ccf547b751277ab60b676e8836d Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 11:02:49 -0700 Subject: [PATCH 215/233] fix propagating fip information through kki files --- lib/std/core.kk | 2 +- lib/std/core/types.kk | 2 +- lib/std/num/int32.kk | 6 +++--- src/Core/Pretty.hs | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index 3804f221c..5d8330e95 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -1067,7 +1067,7 @@ pub fun fold-while-int( start : int, end : int, init : a, f : (int,a) -> e maybe // don't export any definitions here. Full operations are defined in `std/int32`. // ---------------------------------------------------------------------------- -// Convert an `:int32` to an `:int`. +// Convert an `:int32` to an `:int`. pub inline fip extern int( i : int32 ) : int c "kk_integer_from_int" cs inline "(new BigInteger(#1))" diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 8ed6c763e..fe789f525 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -194,7 +194,7 @@ pub noinline fip fun keep( x : a ) : a x // ---------------------------------------------------------------------------- -// Standard functions +// Standard functions // ---------------------------------------------------------------------------- // The identity function returns its argument unchanged diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 9c4dc2ab4..16eebcf07 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -148,7 +148,7 @@ pub fip fun compare( x : int32, y : int32) : order // Return the absolute value of an integer. // Raises an exception if the `:int32` is `min-int32` // (since the negation of `min-int32` equals itself and is still negative) -pub fip fun abs( i : int32 ) : exn int32 +pub fun abs( i : int32 ) : exn int32 if (!i.is-neg) then i elif (i > min-int32) then negate(i) else throw( "std/num/int32/abs: cannot make min-int32 into a positive int32 without overflow" ) @@ -249,14 +249,14 @@ pub fip fun max( i : int32, j : int32 ) : int32 // Truncated division (as in C). See also `(/):(x : int32, y : int32) -> int32`. -pub fip fun cdiv(i:int32, j:int32) : exn int32 +pub fun cdiv(i:int32, j:int32) : exn int32 if (j.is-zero) then throw("std/num/int32/cdiv: modulus by zero") elif (j == -1.int32 && i==min-int32) then throw("std/num/int32/cdiv: modulus overflow in cdiv(min-int32, -1.int32)") else unsafe-cdiv(i,j) // Truncated modulus (as in C). See also `(%):(x : int32, y : int32) -> int32`. -pub fip fun cmod(i:int32, j:int32) : exn int32 +pub fun cmod(i:int32, j:int32) : exn int32 if (j.is-zero) then throw("std/num/int32/cmod: modulus by zero") elif (j == -1.int32 && i==min-int32) then throw("std/num/int32/cmod: modulus overflow in cmod(min-int32, -1.int32)") else unsafe-cmod(i,j) diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index a4f6e63ee..f131fca19 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -273,7 +273,7 @@ prettyDefX env isRec def@(Def name scheme expr vis sort inl nameRng doc) then ppBody <.> semi else -} prettyVis env vis $ - keyword env (show sort) + keyword env (defSortShowFull sort) <+> (if nameIsNil name && coreShowDef env then text "_" else prettyDefName env name) From 9aa14f7b7c01077932bd7ef7bfd3b02bf3fab08a Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 11:06:36 -0700 Subject: [PATCH 216/233] fix fip annotations for standard lib --- lib/std/os/flags.kk | 2 +- lib/std/text/regex.kk | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/std/os/flags.kk b/lib/std/os/flags.kk index d78f2ae0e..ad8a77c82 100644 --- a/lib/std/os/flags.kk +++ b/lib/std/os/flags.kk @@ -182,7 +182,7 @@ fun show-long-flag( parser : flag-parser ) Opt( help=h ) -> "[=" ++ h ++ "]" -type flag-kind +value type flag-kind Flg( set : a -> a ) Arg( arg : string ) End diff --git a/lib/std/text/regex.kk b/lib/std/text/regex.kk index 88fdd53e7..3dc1af405 100644 --- a/lib/std/text/regex.kk +++ b/lib/std/text/regex.kk @@ -25,7 +25,7 @@ extern import // Abstract type of a regular expression object -abstract struct regex( obj: any, src : string ) +abstract value struct regex( obj: any, src : string ) // Return the pattern as a string pub fun source( r : regex ) : string From 8ad9b85360faedec147310c6c922c7b3b4aa4e62 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 11:33:45 -0700 Subject: [PATCH 217/233] suppress spurious shadow warnings --- src/Type/Infer.hs | 37 +++++++++++++++++++++++++------------ src/Type/InferMonad.hs | 16 ++++++++++------ 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index e0a40b929..a67dee114 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -39,7 +39,7 @@ import Common.NamePrim( nameTpOptional, nameOptional, nameOptionalNone, nameCopy , nameTpValueOp, nameClause, nameIdentity , nameMaskAt, nameMaskBuiltin, nameEvvIndex, nameHTag, nameTpHTag , nameInt32, nameOr, nameAnd, nameEffectOpen - , nameCCtxCreate, nameCCtxHoleCreate + , nameCCtxCreate, nameCCtxHoleCreate, isNameTuple ) import Common.Range import Common.Unique @@ -147,7 +147,7 @@ inferDefGroup topLevel (DefRec defs) cont = -- trace ("\ninfer group: " ++ show (map defName defs)) $ do (gamma,infgamma) <- createGammas [] [] defs --coreDefs0 <- extendGamma gamma (mapM (inferRecDef topLevel infgamma) defs) - (coreDefsX,assumed) <- extendGamma False gamma $ extendInfGamma topLevel infgamma $ + (coreDefsX,assumed) <- extendGamma False gamma $ extendInfGammaEx topLevel [] infgamma $ do assumed <- mapM (\def -> lookupInfName (getName def)) defs coreDefs0 <- mapM (\def -> inferDef Instantiated def) defs coreDefs1 <- mapM fixCanonicalName coreDefs0 @@ -393,7 +393,7 @@ inferRecDef topLevel infgamma def do let rng = defRange def nameRng = binderNameRange (defBinder def) eitherRes <- - extendInfGamma topLevel infgamma $ + extendInfGammaEx topLevel [] infgamma $ do mbAssumedType <- lookupInfName (getName def) coreDef <- inferDef Instantiated def case mbAssumedType of @@ -553,8 +553,8 @@ inferExpr propagated expect (Lam binders body rng) Nothing -> Op.freshTVar kindStar Meta Just (tp,_) -> return tp - (tp,eff1,core) <- extendInfGamma False infgamma $ - extendInfGamma False [(nameReturn,createNameInfoX Public nameReturn DefVal (getRange body) returnTp)] $ + (tp,eff1,core) <- extendInfGamma infgamma $ + extendInfGamma [(nameReturn,createNameInfoX Public nameReturn DefVal (getRange body) returnTp)] $ (if (isNamed) then inferIsolated rng (getRange body) body else id) $ -- inferIsolated rng (getRange body) body $ inferExpr propBody expectBody body @@ -801,15 +801,16 @@ inferExpr propagated expect (Case expr branches rng) do (ctp,ceff,ccore) <- allowReturn False $ disallowHole $ inferExpr Nothing Instantiated expr -- infer branches bress <- disallowHole $ + let matchedNames = extractMatchedNames expr in case (propagated,branches) of (Nothing,(b:bs)) -> -- propagate the type of the first branch - do bres@(tpeffs,_) <- inferBranch propagated ctp (getRange expr) b + do bres@(tpeffs,_) <- inferBranch propagated ctp (getRange expr) matchedNames b let tp = case tpeffs of (tp,_):_ -> tp _ -> failure $ "Type.Infer.inferExpr.Case: branch without guard" - bress <- mapM (inferBranch (Just (tp,getRange b)) ctp (getRange expr)) bs + bress <- mapM (inferBranch (Just (tp,getRange b)) ctp (getRange expr) matchedNames) bs return (bres:bress) - _ -> mapM (inferBranch propagated ctp (getRange expr)) branches + _ -> mapM (inferBranch propagated ctp (getRange expr) matchedNames) branches let (tpeffss,bcores) = unzip bress (tps,effs) = unzip (concat tpeffss) -- ensure branches match @@ -863,6 +864,18 @@ inferExpr propagated expect (Case expr branches rng) _ -> failure ("Type.Infer.inferExpr.Case.getTypeName: not a valid scrutinee? " ++ show tp) + extractMatchedNames expr + = case expr of + Parens e _ _ -> extractMatchedNames e + App (Var tname _ _) args _ | isNameTuple tname -> concat (map (extractMatchedNamesX . snd) args) + _ -> extractMatchedNamesX expr + + extractMatchedNamesX expr + = case expr of + Var name _ _ -> [name] + _ -> [] + + inferExpr propagated expect (Var name isOp rng) = inferVar propagated expect name rng True @@ -1535,8 +1548,8 @@ inferVarX propagated expect name rng qname1 tp1 info1 return (itp,eff,coref coreVar) -} -inferBranch :: Maybe (Type,Range) -> Type -> Range -> Branch Type -> Inf ([(Type,Effect)],Core.Branch) -inferBranch propagated matchType matchRange branch@(Branch pattern guards) +inferBranch :: Maybe (Type,Range) -> Type -> Range -> [Name] -> Branch Type -> Inf ([(Type,Effect)],Core.Branch) +inferBranch propagated matchType matchRange matchedNames branch@(Branch pattern guards) = inferPattern matchType (getRange branch) pattern ( \pcore gcores -> -- check for unused pattern bindings @@ -1551,7 +1564,7 @@ inferBranch propagated matchType matchRange branch@(Branch pattern guards) ) $ \infGamma -> -- infGamma <- extractInfGamma pcore - extendInfGamma False infGamma $ + extendInfGammaEx False matchedNames infGamma $ do -- check guard expressions unzip <$> mapM (inferGuard propagated (getRange branch)) guards @@ -1758,7 +1771,7 @@ inferOptionals eff infgamma (par:pars) partp <- subst tvar -- infer expression - (exprTp,exprEff,coreExpr) <- extendInfGamma False infgamma $ inferExpr (Just (partp,getRange par)) + (exprTp,exprEff,coreExpr) <- extendInfGamma infgamma $ inferExpr (Just (partp,getRange par)) (if isRho partp then Instantiated else Generalized False) expr inferUnify (checkOptional fullRange) (getRange expr) partp exprTp diff --git a/src/Type/InferMonad.hs b/src/Type/InferMonad.hs index ca27633df..fce1eb4fc 100644 --- a/src/Type/InferMonad.hs +++ b/src/Type/InferMonad.hs @@ -16,7 +16,7 @@ module Type.InferMonad( Inf, InfGamma -- * Environment , getGamma , extendGamma, extendGammaCore - , extendInfGamma, extendInfGammaCore + , extendInfGamma, extendInfGammaEx, extendInfGammaCore , withGammaType -- * Name resolution @@ -1074,15 +1074,19 @@ extendInfGammaCore :: Bool -> [Core.DefGroup] -> Inf a -> Inf a extendInfGammaCore topLevel [] inf = inf extendInfGammaCore topLevel (coreDefs:coreDefss) inf - = extendInfGamma topLevel (extracts coreDefs) (extendInfGammaCore topLevel coreDefss inf) + = extendInfGammaEx topLevel [] (extracts coreDefs) (extendInfGammaCore topLevel coreDefss inf) where extracts (Core.DefRec defs) = map extract defs extracts (Core.DefNonRec def) = [extract def] extract def = coreDefInfo def -- (Core.defName def,(Core.defNameRange def, Core.defType def, Core.defSort def)) -extendInfGamma :: Bool -> [(Name,NameInfo)] -> Inf a -> Inf a -extendInfGamma topLevel tnames inf +extendInfGamma :: [(Name,NameInfo)] -> Inf a -> Inf a +extendInfGamma tnames inf + = extendInfGammaEx False [] tnames inf + +extendInfGammaEx :: Bool -> [Name] -> [(Name,NameInfo)] -> Inf a -> Inf a +extendInfGammaEx topLevel ignores tnames inf = do env <- getEnv infgamma' <- extend (context env) (gamma env) [] [(unqualify name,info) | (name,info) <- tnames, not (isWildcard name)] (infgamma env) withEnv (\env -> env{ infgamma = infgamma' }) inf @@ -1105,7 +1109,7 @@ extendInfGamma topLevel tnames inf Just info2 | infoCanonicalName name info2 /= nameReturn -> do checkCasingOverlap range name (infoCanonicalName name info2) info2 env <- getEnv - if (not (isHiddenName name) && show name /= "resume" && show name /= "resume-shallow") + if (not (isHiddenName name) && show name /= "resume" && show name /= "resume-shallow" && not (name `elem` ignores)) then infWarning range (Pretty.ppName (prettyEnv env) name <+> text "shadows an earlier local definition or parameter") else return () _ -> return () @@ -1121,7 +1125,7 @@ withGammaType :: Range -> Type -> Inf a -> Inf a withGammaType range tp inf = do defName <- currentDefName name <- uniqueName (show defName) - extendInfGamma False [(name,(InfoVal Public name tp range False))] inf + extendInfGamma [(name,(InfoVal Public name tp range False))] inf currentDefName :: Inf Name currentDefName From 9cb7f18efb49343928c6814b8ca41aacf31e359a Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 12:30:52 -0700 Subject: [PATCH 218/233] annotate more functions as fip as fip (int64 and int functions)) --- lib/std/core.kk | 66 +++++++++++++-------------- lib/std/core/types.kk | 6 +-- lib/std/num/int64.kk | 102 +++++++++++++++++++++--------------------- lib/std/os/env.kk | 8 ++-- src/Kind/Repr.hs | 4 +- 5 files changed, 93 insertions(+), 93 deletions(-) diff --git a/lib/std/core.kk b/lib/std/core.kk index 5d8330e95..36bbf1f08 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -112,10 +112,10 @@ pub fun const( default : a ) : total (( x : b ) -> a) // Standard Data types // ---------------------------------------------------------------------------- -pub fun int( b : bool ) : int +pub fip fun int( b : bool ) : int if b then 1 else 0 -pub fun mbint( m : maybe ) : int +pub fip fun mbint( m : maybe ) : int match m Nothing -> 0 Just(i) -> i @@ -216,7 +216,7 @@ pub fun is-empty( xs : list ) : bool pub co type stream con Next(head:a, tail: stream ) -pub fun int( x : order ) : int +pub fip fun int( x : order ) : int match x Lt -> -1 Eq -> 0 @@ -899,92 +899,92 @@ pub inline fip extern (%) : (int,int) -> int // // See also _Division and modulus for computer scientists, Daan Leijen, 2001_ for further information // available at: . -pub inline extern divmod(x:int,y:int) : (int,int) +pub inline fip extern divmod(x:int,y:int) : (int,int) c "kk_integer_div_mod_tuple" cs "Primitive.IntDivMod" js "$std_core._int_divmod" -pub fun negate(i : int) : int +pub fip fun negate(i : int) : int ~i // Negate an integer. -pub inline extern (~)(i:int) : int +pub inline fip extern (~)(i:int) : int c "kk_integer_neg" cs inline "(-#1)" js "$std_core._int_negate" // Convert an integer to a `:float64`. May return `nan` if the integer is too large to represent as a `:float64`. -pub inline extern float64( i : int) : float64 +pub inline fip extern float64( i : int) : float64 c "kk_integer_as_double" cs "Primitive.IntToDouble" js "$std_core._int_to_double" // Convert an integer to a `:float32`. May return `nan` if the integer is too large to represent as a `:float32`. -pub inline extern float32( i : int) : float32 +pub inline fip extern float32( i : int) : float32 c "kk_integer_as_float" cs "Primitive.IntToFloat" js "$std_core._int_to_float" // Is this an odd integer? -pub inline extern is-odd( i : int ) : bool +pub inline fip extern is-odd( i : int ) : bool c "kk_integer_is_odd" cs inline "!(#1.IsEven)" js "$std_core._int_isodd" // Is this equal to zero? -pub inline extern is-zero( ^x : int) : bool +pub inline fip extern is-zero( ^x : int) : bool c inline "kk_integer_is_zero_borrow(#1)" cs inline "(#1.IsZero)" js "$std_core._int_iszero" // Return the absolute value of an integer. -pub inline extern abs(i : int) : int +pub inline fip extern abs(i : int) : int c "kk_integer_abs" cs "BigInteger.Abs" js "$std_core._int_abs" -pub fun inc( i : int ) : int +pub fip fun inc( i : int ) : int i + 1 -pub fun dec( i : int ) : int +pub fip fun dec( i : int ) : int i - 1 // Calculate `10^exp` -pub fun exp10( exp : int ) : int +pub fip fun exp10( exp : int ) : int 1.mul-exp10(exp) // Raise an integer `i` to the power of `exp`. -pub extern pow( i : int, exp : int ) : int +pub fip extern pow( i : int, exp : int ) : int c "kk_integer_pow" cs "Primitive.IntPow" js "_int_pow" // Raise an integer `i` to the power of `exp`. -pub fun (^)(i : int, exp : int ) : int +pub fip fun (^)(i : int, exp : int ) : int pow(i,exp) // Calculate `2^exp`. -pub fun exp2( exp : int ) : int +pub fip fun exp2( exp : int ) : int pow(2,exp) // Return the number of ending `0` digits of `i`. Return `0` when `i==0`. -pub extern is-exp10( i : int ) : int +pub fip extern is-exp10( i : int ) : int c "kk_integer_ctz" cs "Primitive.IntCountPow10" js "_int_count_pow10" // Return the number of decimal digits of `i`. Return `0` when `i==0`. -pub extern count-digits( i : int ) : int +pub fip extern count-digits( i : int ) : int c "kk_integer_count_digits" cs "Primitive.IntCountDigits" js "_int_count_digits" -pub extern mul-exp10( i : int, n : int ) : int +pub fip extern mul-exp10( i : int, n : int ) : int c "kk_integer_mul_pow10" cs "Primitive.IntMulPow10" js "_int_mul_pow10" -pub extern cdiv-exp10( i : int, n : int ) : int +pub fip extern cdiv-exp10( i : int, n : int ) : int c "kk_integer_cdiv_pow10" cs "Primitive.IntCDivPow10" js "_int_cdiv_pow10" @@ -1000,28 +1000,28 @@ pub fun divmod-exp10( i : int, n : int ) : (int,int) if !cr.is-neg then (cq,cr) else (cq.dec, cr + exp10(n)) // Is this an even integer? -pub fun is-even(i:int) : bool +pub fip fun is-even(i:int) : bool !is-odd(i) // Is the integer positive (stricly greater than zero) -pub fun is-pos(i : int ) : bool - i.sign == Gt +pub fip fun is-pos(i : int ) : bool + i > 0 // Is the integer negative (stricly smaller than zero) -pub fun is-neg(i : int ) : bool - i.sign == Lt +pub fip fun is-neg(i : int ) : bool + i < 0 -pub inline extern sign( ^i : int ) : order +pub inline fip extern sign( ^i : int ) : order c inline "kk_int_as_order(kk_integer_signum_borrow(#1,kk_context()),kk_context())" cs "Primitive.IntSign" js "$std_core._int_sign" // Return the minimum of two integers -pub fun min( i : int, j : int ) : int +pub fip fun min( i : int, j : int ) : int if i <= j then i else j // Return the maximum of two integers -pub fun max( i : int, j : int ) : int +pub fip fun max( i : int, j : int ) : int if i >= j then i else j // Returns the smallest element of a list of integers (or `default` (=`0`) for the empty list) @@ -1129,7 +1129,7 @@ pub fip extern ssize_t( i : int) : ssize_t js "$std_core._int_clamp32" // Convert an `:ssize_t` to an `:int`. -pub inline extern int( i : ssize_t ) : int +pub inline fip extern int( i : ssize_t ) : int c "kk_integer_from_ssize_t" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" @@ -1228,7 +1228,7 @@ pub fip extern int64( i : int) : int64 js "$std_core._int_clamp64" // Convert an `:int64_t` to an `:int`. -pub inline extern int( i : int64 ) : int +pub inline fip extern int( i : int64 ) : int c "kk_integer_from_int64" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int64" @@ -1243,13 +1243,13 @@ pub inline fip fun i64( i : int ) : int64 // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:intptr_t`. -pub extern intptr_t( i : int) : intptr_t +pub fip extern intptr_t( i : int) : intptr_t c "kk_integer_clamp_intptr_t" cs "Primitive.IntToInt64" js "$std_core._int_clamp64" // Convert an `:intptr_t` to an `:int`. -pub inline extern int( i : intptr_t ) : int +pub inline fip extern int( i : intptr_t ) : int c "kk_integer_from_intptr_t" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int64" diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index fe789f525..cedc8aa33 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -15,12 +15,12 @@ */ module std/core/types -pub infixr 65 (++.) pub infixr 60 (++) +pub infixr 55 (++.) pub infixr 30 (&&) pub infixr 20 (||) -// build: 105 +// build: 108 // ---------------------------------------------------------------------------- // Core types @@ -80,7 +80,7 @@ pub value type intptr_t // Provides currently no operations and currently only used for storage and for interaction with external code. pub value type float32 -// An any type. Used for extern calls +// An any type. Used for external calls pub type any // Internal type used for in-place update of unique pattern matches diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index f31a4999b..1cd1b6244 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -32,23 +32,23 @@ pub fun bool( i : int64 ) : bool // Convert a boolean to an `:int64`. -pub fun int64( b : bool ) : int64 +pub fip fun int64( b : bool ) : int64 if b then one else zero // Convert an `:int32` to an `:int64` (using sign extension). -pub inline extern int64( i : int32 ) : int64 +pub inline fip extern int64( i : int32 ) : int64 c inline "(int64_t)(#1)" js "$std_core._int64_from_int32" // Convert an `:int32` to an `:int64` interpreting the `:int32` as unsigned. -pub inline extern uint64( i : int32 ) : int64 +pub inline fip extern uint64( i : int32 ) : int64 c inline "(int64_t)((uint32_t)(#1))" js "$std_core._int64_from_uint32" // Clamp an `:int64` to an `:int32` // `-1.int64.int32 == -1.int32` // `0x8000_0000.int64.int32 == 0x7FFF_FFFF.int32` (clamped) -pub inline extern int32( i : int64 ) : int32 +pub inline fip extern int32( i : int64 ) : int32 c "kk_int64_clamp_int32" js "$std_core._int64_clamp_int32" @@ -56,13 +56,13 @@ pub inline extern int32( i : int64 ) : int32 // (and thus clamp between 0 and 0xFFFFFFFF). // `-1.int64.uint32 == 0.int32` (clamped) // `0xFFFFFFFF.int64.uint32 == -1.int32` -pub inline extern uint32( i : int64 ) : int32 +pub inline fip extern uint32( i : int64 ) : int32 c "kk_int64_clamp_uint32" js "$std_core._int64_clamp_uint32" // Create an `:int64` `i` from the bits of `lo` and `hi` such // that `i.int = hi.int * 0x1_0000_0000 + lo.uint`. -pub fun int64( lo : int32, hi : int32 ) : int64 +pub fip fun int64( lo : int32, hi : int32 ) : int64 hi.int64.shl(32).or(lo.uint64) // Convert an `:int` to `:int64` but interpret the `int` as an unsigned 64-bit value. @@ -75,7 +75,7 @@ pub fun uint64( i : int ) : int64 // Convert an `:int64` to an `:int` but interpret the `:int64` as a 64-bit unsigned value. -pub fun uint( i : int64 ) : int +pub fip fun uint( i : int64 ) : int if i.is-neg then 0x1_0000_0000_0000_0000 + i.int else i.int @@ -94,34 +94,34 @@ pub fun show-hex64( i : int64, width : int = 16, use-capitals : bool = True, pre std/core/show-hex(i.uint,width,use-capitals,pre) -pub inline extern (<=) : (int64,int64) -> bool { inline "(#1 <= #2)" } -pub inline extern (==) : (int64,int64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (int64,int64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (>=) : (int64,int64) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (int64,int64) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (int64,int64) -> bool { inline "(#1 > #2)" } +pub inline fip extern (<=) : (int64,int64) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (==) : (int64,int64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (int64,int64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (>=) : (int64,int64) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (int64,int64) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (int64,int64) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (int64,int64) -> int64 +pub inline fip extern (+) : (int64,int64) -> int64 c inline "(int64_t)((uint64_t)#1 + (uint64_t)#2)" js inline "BigInt.asIntN(64,#1 + #2)" -pub inline extern (-) : (int64,int64) -> int64 +pub inline fip extern (-) : (int64,int64) -> int64 inline "(int64_t)((uint64_t)#1 - (uint64_t)#2)" js inline "BigInt.asIntN(64,#1 - #2)" -pub inline extern is-neg( i : int64 ) : bool +pub inline fip extern is-neg( i : int64 ) : bool inline "0 > #1" js inline "0n > #1" -pub inline extern is-pos( i : int64 ) : bool +pub inline fip extern is-pos( i : int64 ) : bool inline "0 < #1" js inline "0n < #1" -pub inline extern is-zero( i : int64 ) : bool +pub inline fip extern is-zero( i : int64 ) : bool inline "0 == #1" js inline "0n === #1" @@ -129,39 +129,39 @@ pub inline extern is-zero( i : int64 ) : bool pub val zero = 0.int64 pub val one = 1.int64 -pub fun sign( i : int64 ) : order +pub fip fun sign( i : int64 ) : order if i.is-pos then Gt elif i.is-neg then Lt else Eq // Returns `true` if the integer `i` is an odd number. -pub fun is-odd( i : int64 ) : bool +pub fip fun is-odd( i : int64 ) : bool and(i,one)==one // Returns `true` if the integer `i` is an even number. -pub fun is-even( i : int64 ) : bool +pub fip fun is-even( i : int64 ) : bool and(i,one)==zero // Increment a 64-bit integer. -pub fun inc( i : int64 ) : int64 +pub fip fun inc( i : int64 ) : int64 i + 1.int64 // Decrement a 64-bit integer. -pub fun dec( i : int64 ) : int64 +pub fip fun dec( i : int64 ) : int64 i - 1.int64 // Multiply two 64-bit integers. -pub inline extern (*) : (int64,int64) -> int64 +pub inline fip extern (*) : (int64,int64) -> int64 c inline "(int64_t)((uint64_t)#1 * (uint64_t)#2)"; js inline "BigInt.asIntN(64,#1 * #2)" -pub fun compare( x : int64, y : int64) : order +pub fip fun compare( x : int64, y : int64) : order if x < y then Lt elif x > y then Gt else Eq @@ -179,7 +179,7 @@ pub fun abs( i : int64 ) : exn int64 // Return the absolute value of an integer. // Returns 0 if the `:int64` is `min-int64` // (since the negation of `min-int64` equals itself and is still negative) -pub fun abs0( i : int64 ) : int64 +pub fip fun abs0( i : int64 ) : int64 if !i.is-neg then i elif i > min-int64 then negate(i) else 0.int64 @@ -187,58 +187,58 @@ pub fun abs0( i : int64 ) : int64 // Take the bitwise _and_ of two `:int64`s -pub inline extern and : (int64,int64) -> int64 +pub inline fip extern and : (int64,int64) -> int64 inline "#1 & #2" // Take the bitwise _or_ of two `:int64`s -pub inline extern or : (int64,int64) -> int64 +pub inline fip extern or : (int64,int64) -> int64 inline "#1 | #2" // Take the bitwise _xor_ of two `:int64`s -pub inline extern xor : (int64,int64) -> int64 +pub inline fip extern xor : (int64,int64) -> int64 inline "#1 ^ #2"; // Take the bitwise _xor_ of two `:int64`s -pub fun(^)( x : int64, y : int64) : int64 +pub fip fun (^)( x : int64, y : int64) : int64 xor(x,y) // Bitwise _not_ of an `:int64`, i.e. flips all bits. -pub inline extern not : ( i : int64 ) -> int64 +pub inline fip extern not : ( i : int64 ) -> int64 inline "~#1" js inline "BigInt.asIntN(64, ~#1)" // Shift an `:int64` `i` to the left by `n % 64` bits. -inline extern shl64 : (int64,int64) -> int64 +inline fip extern shl64 : (int64,int64) -> int64 c inline "kk_shl64(#1,#2)" js "$std_core._int64_shl" // Shift an `:int64` `i` to the left by `n % 64` bits. -pub fun shl( i : int64, shift : int) : int64 +pub fip fun shl( i : int64, shift : int) : int64 shl64(i,shift.int64) // Logical shift an `:int64` to the right by `n % 64` bits. Shift in zeros from the left. -inline extern shr64 : (int64,int64) -> int64 +inline fip extern shr64 : (int64,int64) -> int64 c inline "(int64_t)kk_shr64(#1,#2)" cs inline "(int64)(((Uint64)#1)>>#2)" js "$std_core._int64_shr" // Logical shift an `:int64` to the right by `n % 64` bits. Shift in zeros from the left. -pub fun shr( i : int64, shift : int) : int64 +pub fip fun shr( i : int64, shift : int) : int64 shr64(i,shift.int64) // Arithmetic shift an `:int64` to the right by `n % 64` bits. Preserves the sign bit. -inline extern sar64 : (int64,int64) -> int64 +inline fip extern sar64 : (int64,int64) -> int64 c inline "kk_sar64(#1,#2)" js "$std_core._int64_sar" // Arithmetic shift an `:int64` to the right by `n % 64` bits. Shift in the sign bit from the left. -pub fun sar( i : int64, shift : int) : int64 +pub fip fun sar( i : int64, shift : int) : int64 sar64(i,shift.int64) // Bitwise rotate an `:int64` `n % 64` bits to the left. -inline extern rotl64( i : int64, n : int64 ) : int64 +inline fip extern rotl64( i : int64, n : int64 ) : int64 c inline "(int64_t)kk_bits_rotl64(#1,#2)" js "$std_core._int64_rotl" @@ -247,21 +247,21 @@ pub fun rotl( i : int64, shift : int) : int64 rotl64(i,shift.int64) // Bitwise rotate an `:int64` `n % 64` bits to the right. -inline extern rotr64( i : int64, n : int64 ) : int64 +inline fip extern rotr64( i : int64, n : int64 ) : int64 c inline "(int64_t)kk_bits_rotr64(#1,#2)" js "$std_core._int64_rotr" // Bitwise rotate an `:int64` `n % 64` bits to the right. -pub fun rotr( i : int64, shift : int) : int64 +pub fip fun rotr( i : int64, shift : int) : int64 rotr64(i,shift.int64) // Return the minimum of two integers -pub fun min( i : int64, j : int64 ) : int64 +pub fip fun min( i : int64, j : int64 ) : int64 if i <= j then i else j // Return the maximum of two integers -pub fun max( i : int64, j : int64 ) : int64 +pub fip fun max( i : int64, j : int64 ) : int64 if i >= j then i else j @@ -280,27 +280,27 @@ pub fun cmod(i:int64, j:int64) : exn int64 // Truncated division (as in C). See also `(/):(x : int64, y : int64) -> int64`. -inline extern unsafe-cdiv : (int64,int64) -> int64 +inline fip extern unsafe-cdiv : (int64,int64) -> int64 inline "#1 / #2" // Truncated modulus (as in C). See also `(%):(x : int64, y : int64) -> int64`. -inline extern unsafe-cmod : (int64,int64) -> int64 +inline fip extern unsafe-cmod : (int64,int64) -> int64 inline "#1 % #2" // Convert an 64-bit integer to a `:float64`. -pub fun float64( i : int64 ) : float64 +pub fip fun float64( i : int64 ) : float64 i.int.float64 // Negate a 64-bit integer -pub fun negate( i : int64 ) : int64 +pub fip fun negate( i : int64 ) : int64 0.int64 - i // Negate an 64-bit integer -pub fun (~)(i : int64) : total int64 +pub fip fun (~)(i : int64) : total int64 0.int64 - i @@ -327,7 +327,7 @@ Of course `(min-int64 + 1) / -1` is again positive (namely `max-int64`). See also _Division and modulus for computer scientists, Daan Leijen, 2001_ [pdf](http://research.microsoft.com/pubs/151917/divmodnote.pdf) . */ -pub fun (/)( x : int64, y : int64 ) : int64 +pub fip fun (/)( x : int64, y : int64 ) : int64 if y == 0.int64 return 0.int64 if y == -1.int64 && x==min-int64 return x val q = unsafe-cdiv(x,y) @@ -338,7 +338,7 @@ pub fun (/)( x : int64, y : int64 ) : int64 // Euclidean-0 modulus. See `(/):(x : int64, y : int64) -> int64` division for more information. -pub fun (%)( x : int64, y : int64 ) : int64 +pub fip fun (%)( x : int64, y : int64 ) : int64 if y == 0.int64 return x if y == -1.int64 && x==min-int64 return 0.int64 val r = unsafe-cmod(x,y) @@ -346,7 +346,7 @@ pub fun (%)( x : int64, y : int64 ) : int64 elif y > 0.int64 then r + y else r - y -pub fun divmod( x :int64, y :int64 ) : (int64,int64) +pub fip fun divmod( x :int64, y :int64 ) : (int64,int64) if y.is-zero return (zero,x) if y == -1.int64 && x==min-int64 return (x,0.int64) val q = unsafe-cdiv(x,y) @@ -364,7 +364,7 @@ pub fun fold-int64( start : int64, end : int64, init : a, f : (int64,a) -> e a ) // Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). // If `start > end` the function returns without any call to `action` . // If `action` returns `Just`, the iteration is stopped and the result returned -pub fun for-while64( start: int64, end : int64, action : (int64) -> e maybe ) : e maybe +pub fun for-while64( start: int64, end : int64, ^action : (int64) -> e maybe ) : e maybe fun rep( i : int64 ) if i <= end then match action(i) diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 952f30d74..2faaa636b 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -98,14 +98,14 @@ pub extern get-cpu-is-little-endian() : ndet bool c "kk_cpu_is_little_endian" js inline "true" -// Return the processor architecture natural machine word size in bits. +// Return the processor natural integer register size in bits. // -// Note: Usually this equals the `get-cpu-object-bits` and `get-cpu-pointer-bits` on modern cpu's +// Note: Usually this equals the `get-cpu-size-bits` and `get-cpu-pointer-bits` on modern cpu's // but they can differ on segmented architectures. // For example, on the old x86 FAR-NEAR model, the addresses are 32-bit but the maximum object size is 16-bit. // Or on the more recent-[x32 ABI](https://en.wikipedia.org/wiki/X32_ABI) // the addresses and objects are 32-bits but the architecture has 64-bit registers. -pub extern get-cpu-arch-bits() : ndet int +pub extern get-cpu-int-bits() : ndet int c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(kk_intx_t),kk_context())" js inline "32" @@ -116,7 +116,7 @@ pub extern get-cpu-size-bits() : ndet int js inline "32" // Return the processor maximum address size in bits (`8*sizeof(vaddr_t)`). This is usually -// equal to the `get-cpu-pointer-bits` but may be different on capability architectures like ARM CHERI. +// equal to the `get-cpu-pointer-bits` but may be smaller on capability architectures like ARM CHERI. pub extern get-cpu-address-bits() : ndet int c inline "kk_integer_from_int(kk_cpu_address_bits(kk_context()),kk_context())" js inline "32" diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index 18d3d8055..ef355fd2c 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -72,8 +72,8 @@ createDataDef emitError emitWarning lookupDataInfo -> do let wouldGetTagField = (conCount > 1 && not isEnum) size = valueReprSize platform vr + (if wouldGetTagField then sizeField platform else 0) when ((size <= 2*sizePtr platform) && (maxMembers <= 3) && canbeValue) $ - emitWarning $ text "may be better declared as a value type for efficiency (e.g. 'value type/struct')" <-> - text "or declare as a reference type (e.g. 'ref type/struct') to suppress this warning" + emitWarning $ text "may be better declared as a value type for efficiency (e.g. 'value type/struct')," <-> + text "or declared as a reference type to suppress this warning (e.g. 'ref type/struct')" return DataDefNormal _ -> return DataDefNormal From ef41bb58eb70eddec361e86a43a8f28bc7688399 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 13:46:59 -0700 Subject: [PATCH 219/233] update to lts-21.0 (ghc 9.4.5) --- src/Backend/C/Box.hs | 2 +- src/Backend/C/FromCore.hs | 6 +++--- src/Backend/CSharp/FromCore.hs | 4 ++-- src/Backend/JavaScript/FromCore.hs | 6 +++--- src/Common/Error.hs | 4 ++-- src/Common/Unique.hs | 10 +++++----- src/Compiler/Compile.hs | 4 ++-- src/Core/AnalysisCCtx.hs | 4 ++-- src/Core/Check.hs | 6 +++--- src/Core/Core.hs | 6 +++--- src/Core/Divergent.hs | 6 +++--- src/Core/FunLift.hs | 4 ++-- src/Core/Inline.hs | 6 +++--- src/Core/Monadic.hs | 6 +++--- src/Core/MonadicLift.hs | 6 +++--- src/Core/Simplify.hs | 7 ++++--- src/Core/UnReturn.hs | 6 +++--- src/Core/Uniquefy.hs | 4 ++-- src/Core/Unroll.hs | 6 +++--- src/Kind/InferMonad.hs | 6 +++--- src/Static/FixityResolve.hs | 6 +++--- src/Type/InferMonad.hs | 6 +++--- src/Type/Unify.hs | 6 +++--- stack.yaml | 3 ++- 24 files changed, 66 insertions(+), 64 deletions(-) diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index 994406177..18e47608a 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -157,7 +157,7 @@ boxPattern fromTp pat | cType (fromTp) /= cType toTp PatCon{} -> patTypeRes pat PatVar tname _ -> typeOf tname PatLit lit -> typeOf lit - PatWild -> typeAny -- cannot happen + -- PatWild -> typeAny -- cannot happen isComplexCoerce coerce = case (cType fromTp, cType toTp) of diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index c28daeea5..3bf6fb0c8 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -2308,11 +2308,11 @@ instance Functor Asm where (x,st') -> (f x, st')) instance Applicative Asm where - pure = return - (<*>) = ap + pure x = Asm (\env st -> (x,st)) + (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) diff --git a/src/Backend/CSharp/FromCore.hs b/src/Backend/CSharp/FromCore.hs index 804fa3d05..5e7799891 100644 --- a/src/Backend/CSharp/FromCore.hs +++ b/src/Backend/CSharp/FromCore.hs @@ -1524,11 +1524,11 @@ instance Functor Asm where fmap f (Asm a) = Asm (\env st -> case a env st of (x,st') -> (f x, st')) instance Applicative Asm where - pure = return + pure x = Asm (\env st -> (x,st)) (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index 1e2471334..717f3ecdc 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -1087,11 +1087,11 @@ instance Functor Asm where (x,st') -> (f x, st')) instance Applicative Asm where - pure = return - (<*>) = ap + pure x = Asm (\env st -> (x,st)) + (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) diff --git a/src/Common/Error.hs b/src/Common/Error.hs index 324ceba2e..204af4a0b 100644 --- a/src/Common/Error.hs +++ b/src/Common/Error.hs @@ -135,11 +135,11 @@ instance Functor Error where Error msg w -> Error msg w instance Applicative Error where - pure = return + pure x = Ok x [] (<*>) = ap instance Monad Error where - return x = Ok x [] + -- return = pure e >>= f = case e of Ok x w -> addWarnings w (f x) Error msg w -> Error msg w diff --git a/src/Common/Unique.hs b/src/Common/Unique.hs index 6a8e26e2f..5335539bd 100644 --- a/src/Common/Unique.hs +++ b/src/Common/Unique.hs @@ -22,10 +22,6 @@ import Control.Monad import Control.Monad.Trans import Control.Arrow -instance Applicative Unique where - pure = return - (<*>) = ap - class (Monad m, Functor m) => HasUnique m where updateUnique :: (Int -> Int) -> m Int -- getUnique :: m Int @@ -98,8 +94,12 @@ liftUnique uniq instance Functor Unique where fmap f (Unique u) = Unique (\i -> case u i of (x,j) -> (f x,j)) +instance Applicative Unique where + pure x = Unique (\i -> (x,i)) + (<*>) = ap + instance Monad Unique where - return x = Unique (\i -> (x,i)) + -- return = pure (Unique u) >>= f = Unique (\i -> case u i of (x,j) -> case f x of Unique v -> v j) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 660068352..a449fe740 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -146,11 +146,11 @@ instance Functor IOErr where fmap f (IOErr ie) = IOErr (fmap (fmap f) ie) instance Applicative IOErr where - pure = return + pure x = IOErr (return (return x)) (<*>) = ap instance Monad IOErr where - return x = IOErr (return (return x)) + -- return = pure (IOErr ie) >>= f = IOErr (do err <- ie case checkError err of Right (x,w) -> case f x of diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index 7b9699a79..515fb0830 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -228,11 +228,11 @@ instance Functor CCtx where Err errs -> Err errs) instance Applicative CCtx where - pure = return + pure x = CCtx (\u g -> Ok x u) (<*>) = ap instance Monad CCtx where - return x = CCtx (\u g -> Ok x u) + -- return = pure (CCtx c) >>= f = CCtx (\u g -> case c u g of Ok x u' -> case f x of CCtx d -> d u' g diff --git a/src/Core/Check.hs b/src/Core/Check.hs index 83e6db736..4a7413295 100644 --- a/src/Core/Check.hs +++ b/src/Core/Check.hs @@ -70,11 +70,11 @@ instance Functor Check where Err doc -> Err doc) instance Applicative Check where - pure = return - (<*>) = ap + pure x = Check (\u g -> Ok x u) + (<*>) = ap instance Monad Check where - return x = Check (\u g -> Ok x u) + -- return = pure (Check c) >>= f = Check (\u g -> case c u g of Ok x u' -> case f x of Check d -> d u' g diff --git a/src/Core/Core.hs b/src/Core/Core.hs index c1c4a0633..e18bb44d2 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -588,11 +588,11 @@ instance Functor CorePhase where return (CPState (f x) uniq' defs')) instance Applicative CorePhase where - pure = return - (<*>) = ap + pure x = CP (\uniq defs -> return (CPState x uniq defs)) + (<*>) = ap instance Monad CorePhase where - return x = CP (\uniq defs -> return (CPState x uniq defs)) + -- return = pure (CP cp) >>= f = CP (\uniq defs -> do (CPState x uniq' defs') <- cp uniq defs case f x of CP cp' -> cp' uniq' defs') diff --git a/src/Core/Divergent.hs b/src/Core/Divergent.hs index da3aad47c..b1ee0f01d 100644 --- a/src/Core/Divergent.hs +++ b/src/Core/Divergent.hs @@ -104,11 +104,11 @@ instance Functor Div where fmap f (Div d) = Div (\rel -> case d rel of (x,calls) -> (f x, calls)) instance Applicative Div where - pure = return - (<*>) = ap + pure x = Div (\rel -> (x,[])) + (<*>) = ap instance Monad Div where - return x = Div (\rel -> (x,[])) + -- return = pure (Div d) >>= f = Div (\rel -> case d rel of (x,calls1) -> case f x of Div d2 -> case d2 rel of diff --git a/src/Core/FunLift.hs b/src/Core/FunLift.hs index 598c26511..25e0c8a41 100644 --- a/src/Core/FunLift.hs +++ b/src/Core/FunLift.hs @@ -320,11 +320,11 @@ instance Functor Lift where Ok x st' dgs -> Ok (f x) st' dgs) instance Applicative Lift where - pure = return + pure x = Lift (\env st -> Ok x st []) (<*>) = ap instance Monad Lift where - return x = Lift (\env st -> Ok x st []) + -- return = pure (Lift c) >>= f = Lift (\env st -> case c env st of Ok x st' dgs -> case f x of Lift d -> case d env st' of diff --git a/src/Core/Inline.hs b/src/Core/Inline.hs index 9ca16fbc2..be7bb9ce4 100644 --- a/src/Core/Inline.hs +++ b/src/Core/Inline.hs @@ -215,11 +215,11 @@ instance Functor Inl where Ok x st' -> Ok (f x) st') instance Applicative Inl where - pure = return - (<*>) = ap + pure x = Inl (\env st -> Ok x st) + (<*>) = ap instance Monad Inl where - return x = Inl (\env st -> Ok x st) + -- return = pure (Inl c) >>= f = Inl (\env st -> case c env st of Ok x st' -> case f x of Inl d -> d env st' ) diff --git a/src/Core/Monadic.hs b/src/Core/Monadic.hs index 494b502db..db1e87470 100644 --- a/src/Core/Monadic.hs +++ b/src/Core/Monadic.hs @@ -377,11 +377,11 @@ instance Functor Mon where Ok x st' -> Ok (f x) st') instance Applicative Mon where - pure = return - (<*>) = ap + pure x = Mon (\env st -> Ok x st) + (<*>) = ap instance Monad Mon where - return x = Mon (\env st -> Ok x st) + -- return = pure (Mon c) >>= f = Mon (\env st -> case c env st of Ok x st' -> case f x of Mon d -> d env st' ) diff --git a/src/Core/MonadicLift.hs b/src/Core/MonadicLift.hs index 679961a50..58ab7cb0f 100644 --- a/src/Core/MonadicLift.hs +++ b/src/Core/MonadicLift.hs @@ -288,11 +288,11 @@ instance Functor Lift where Ok x st' dgs -> Ok (f x) st' dgs) instance Applicative Lift where - pure = return - (<*>) = ap + pure x = Lift (\env st -> Ok x st []) + (<*>) = ap instance Monad Lift where - return x = Lift (\env st -> Ok x st []) + -- return = pure (Lift c) >>= f = Lift (\env st -> case c env st of Ok x st' dgs -> case f x of Lift d -> case d env st' of diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index 9767f69f4..54339fc27 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -497,6 +497,7 @@ instance Applicative Match where NoMatch -> NoMatch instance Monad Match where + -- return = pure m >>= f = case m of Match x -> f x Unknown -> Unknown @@ -918,11 +919,11 @@ instance Functor Simp where fmap f (Simplify c) = Simplify (\u env -> case c u env of Ok x u' -> Ok (f x) u') instance Applicative Simp where - pure = return - (<*>) = ap + pure x = Simplify (\u g -> Ok x u) + (<*>) = ap instance Monad Simp where - return x = Simplify (\u g -> Ok x u) + -- return = pure (Simplify c) >>= f = Simplify (\u g -> case c u g of Ok x u' -> case f x of Simplify d -> d u' g) diff --git a/src/Core/UnReturn.hs b/src/Core/UnReturn.hs index ce3af148e..0f18eb58a 100644 --- a/src/Core/UnReturn.hs +++ b/src/Core/UnReturn.hs @@ -326,11 +326,11 @@ instance Functor UR where Ok x st' -> Ok (f x) st') instance Applicative UR where - pure = return - (<*>) = ap + pure x = UR (\env st -> Ok x st) + (<*>) = ap instance Monad UR where - return x = UR (\env st -> Ok x st) + -- return = pure (UR c) >>= f = UR (\env st -> case c env st of Ok x st' -> case f x of UR d -> d env st' ) diff --git a/src/Core/Uniquefy.hs b/src/Core/Uniquefy.hs index 301d20343..888b9b4f4 100644 --- a/src/Core/Uniquefy.hs +++ b/src/Core/Uniquefy.hs @@ -36,11 +36,11 @@ instance Functor Un where (x,st1) -> (f x,st1)) instance Applicative Un where - pure = return + pure x = Un (\st -> (x,st)) (<*>) = ap instance Monad Un where - return x = Un (\st -> (x,st)) + -- return = pure (Un u) >>= f = Un (\st0 -> case u st0 of (x,st1) -> case f x of Un u1 -> u1 st1) instance HasUnique Un where diff --git a/src/Core/Unroll.hs b/src/Core/Unroll.hs index cd774a38a..69275b1e2 100644 --- a/src/Core/Unroll.hs +++ b/src/Core/Unroll.hs @@ -201,11 +201,11 @@ instance Functor Unroll where Ok x st' -> Ok (f x) st') instance Applicative Unroll where - pure = return - (<*>) = ap + pure x = Unroll (\env st -> Ok x st) + (<*>) = ap instance Monad Unroll where - return x = Unroll (\env st -> Ok x st) + -- return = pure (Unroll c) >>= f = Unroll (\env st -> case c env st of Ok x st' -> case f x of Unroll d -> d env st' ) diff --git a/src/Kind/InferMonad.hs b/src/Kind/InferMonad.hs index 604ddb29f..b584ab5ae 100644 --- a/src/Kind/InferMonad.hs +++ b/src/Kind/InferMonad.hs @@ -77,11 +77,11 @@ instance Functor KInfer where = KInfer (\env -> \st -> let r = ki env st in r{ result = f (result r) }) instance Applicative KInfer where - pure = return - (<*>) = ap + pure x = KInfer (\env -> \st -> KResult x [] [] st) + (<*>) = ap instance Monad KInfer where - return x = KInfer (\env -> \st -> KResult x [] [] st) + -- return = pure (KInfer ki) >>= f = KInfer (\env -> \st -> case ki env st of diff --git a/src/Static/FixityResolve.hs b/src/Static/FixityResolve.hs index e55a6e6f2..04ca9c65f 100644 --- a/src/Static/FixityResolve.hs +++ b/src/Static/FixityResolve.hs @@ -173,11 +173,11 @@ instance Functor FixM where fmap = liftM instance Applicative FixM where - pure = return - (<*>) = ap + pure x = FixM (\fixmap -> Res x []) + (<*>) = ap instance Monad FixM where - return x = FixM (\fixmap -> Res x []) + -- return = pure (FixM fm) >>= f = FixM (\fixmap -> case fm fixmap of Res x errs1 -> case f x of FixM fm' -> case fm' fixmap of diff --git a/src/Type/InferMonad.hs b/src/Type/InferMonad.hs index fce1eb4fc..6031a7973 100644 --- a/src/Type/InferMonad.hs +++ b/src/Type/InferMonad.hs @@ -869,11 +869,11 @@ instance Functor Inf where Err err w -> Err err w) instance Applicative Inf where - pure = return - (<*>) = ap + pure x = Inf (\env st -> Ok x st []) + (<*>) = ap instance Monad Inf where - return x = Inf (\env st -> Ok x st []) + -- return = pure (Inf i) >>= f = Inf (\env st0 -> case i env st0 of Ok x st1 w1 -> case f x of Inf j -> case j env st1 of diff --git a/src/Type/Unify.hs b/src/Type/Unify.hs index 64d9a5b44..f6a19f24c 100644 --- a/src/Type/Unify.hs +++ b/src/Type/Unify.hs @@ -501,11 +501,11 @@ instance Functor Unify where Err err st2 -> Err err st2) instance Applicative Unify where - pure = return - (<*>) = ap + pure x = Unify (\st -> Ok x st) + (<*>) = ap instance Monad Unify where - return x = Unify (\st -> Ok x st) + -- return = pure (Unify u) >>= f = Unify (\st1 -> case u st1 of Ok x st2 -> case f x of Unify u2 -> u2 st2 diff --git a/stack.yaml b/stack.yaml index 70fad5f80..af92d5e22 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,8 +13,9 @@ # $ cabal new-run koka # See also . +resolver: lts-21.0 # ghc 9.4.5 # resolver: lts-19.7 # ghc 9.0.2 -resolver: lts-18.28 # ghc 8.10.7 -- works for M1 +# resolver: lts-18.28 # ghc 8.10.7 -- works for M1 # resolver: lts-18.6 # ghc 8.10.4 # resolver: lts-14.27 # ghc 8.6.5 # resolver: lts-9.21 # ghc 8.0.2 -- works for older linux-arm64 From cf4629038c90b845876806fcf73e6d186e36e5e2 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 14:08:15 -0700 Subject: [PATCH 220/233] update clang for windows install --- util/install.bat | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/util/install.bat b/util/install.bat index a6ce2d8e4..9cd61fde5 100644 --- a/util/install.bat +++ b/util/install.bat @@ -17,11 +17,12 @@ set KOKA_PREV_VERSION= set KOKA_PREV_PREFIX= set KOKA_ARCH=x64 -set CLANG_VERSION=13.0.0 +set CLANG_VERSION=16.0.6 set CLANG_INSTALL_BASE=LLVM-%CLANG_VERSION%-win64.exe set CLANG_INSTALL=%TEMP%\%CLANG_INSTALL_BASE% set CLANG_INSTALL_URL=https://github.com/llvm/llvm-project/releases/download/llvmorg-%CLANG_VERSION%/%CLANG_INSTALL_BASE% -set CLANG_INSTALL_SHA256=f81f08a8bd9d787ec0505a7475cdff9653516cbbc5804e973f8749a2139fa1cb +set CLANG_INSTALL_SHA256=9a8cd30cc92fdf403d96217347861545a5bbff7a1a1a8527b5785ff0e9101111 + rem check if %LOCALAPPDATA% was not empty if "%KOKA_PREFIX%" == "\koka" (set KOKA_PREFIX=c:\usr\local\koka) From ba9433fdb2eb345072e274fb982a697b241668d8 Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 17:30:15 -0700 Subject: [PATCH 221/233] fix scan field size calculation; bump version; fix regex-compat version --- kklib/ide/vs2022/kklib-test-interactive.vcxproj | 7 +------ kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters | 7 +------ koka.cabal | 6 +++--- package.yaml | 6 +++--- src/Backend/C/FromCore.hs | 6 +++--- stack.yaml | 4 ++-- test/cgen/specialize/branch.kk | 2 +- util/install.bat | 2 +- util/install.sh | 2 +- util/minbuild.sh | 2 +- 10 files changed, 17 insertions(+), 27 deletions(-) diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj index 6dcac046f..56dce2689 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -168,15 +168,10 @@ - - - - + - - diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters index fe2b9b97c..62586dda1 100644 --- a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -8,12 +8,7 @@ - - - - - - + diff --git a/koka.cabal b/koka.cabal index 22c415ca9..f1c50003a 100644 --- a/koka.cabal +++ b/koka.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: koka -version: 2.4.1 +version: 2.4.2 description: Please see the README on GitHub at homepage: https://github.com/koka-lang/koka#readme bug-reports: https://github.com/koka-lang/koka/issues @@ -133,7 +133,7 @@ executable koka CPP OverloadedStrings ghc-options: -rtsopts -j8 - cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.1" -DREADLINE=0 + cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.2" -DREADLINE=0 include-dirs: src/Platform/cpp/Platform c-sources: @@ -181,7 +181,7 @@ test-suite koka-test , mtl , parsec , process - , regex-compat-tdfa + , regex-compat >=0.95.2.1 , text , time default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 886039468..59440a067 100644 --- a/package.yaml +++ b/package.yaml @@ -6,7 +6,7 @@ # - util/minbuild name: koka -version: 2.4.1 +version: 2.4.2 github: "koka-lang/koka" license: Apache-2.0 author: Daan Leijen @@ -53,7 +53,7 @@ executables: cpp-options: - -DKOKA_MAIN="koka" - -DKOKA_VARIANT="release" - - -DKOKA_VERSION="2.4.1" + - -DKOKA_VERSION="2.4.2" - -DREADLINE=0 # 1:getline, 2:readline, 3:haskeline, or 0:isocline when: - condition: os(windows) @@ -76,6 +76,6 @@ tests: - hspec - hspec-core - process - - regex-compat-tdfa + - regex-compat >= 0.95.2.1 - json diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 3bf6fb0c8..83ce27aa5 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -512,8 +512,8 @@ genTypeDefPost (Data info isExtend) <+> block (text "kk_value_tag_t _tag;" <-> text "union" <+> block (vcat ( map ppStructConField (dataInfoConstrs info) - ++ (if (maxScanCount > 0 && minScanCount /= maxScanCount) - then [text "kk_box_t _fields[" <.> pretty maxScanCount <.> text "];"] + ++ (if (maxScanCount > 1 && minScanCount /= maxScanCount) + then [text "kk_box_t _fields[" <.> pretty (maxScanCount - 1) <.> text "];"] -- -1 as it includes the tag field itself else []) )) <+> text "_cons;") <.> semi -- <-> text "kk_struct_packed_end" <-> ppVis (dataInfoVis info) <.> text "typedef struct" <+> ppName name <.> text "_s" <+> ppName (typeClassName name) <.> semi @@ -676,7 +676,7 @@ genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount ++ [tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null();" - | i <- [scanCount..(maxScanCount-1)]] + | i <- [(scanCount-1) .. (maxScanCount-2)]] -- -1 as the scanCount includes the struct tag field else [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi {- <+> text "= {0}; // zero initializes all fields" -} ] ++ map (assignField (\fld -> tmp <.> text "." <.> fld)) conFields ++ [tmp <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] diff --git a/stack.yaml b/stack.yaml index af92d5e22..fe324a229 100644 --- a/stack.yaml +++ b/stack.yaml @@ -25,8 +25,8 @@ packages: - '.' extra-deps: -- regex-compat-tdfa-0.95.1.4 # only needed for koka-test -- json-0.10 # only needed for koka-test +- regex-compat-0.95.2.1 # only needed for koka-test (use 0.95.1.4 for pre lts-21.0) +- json-0.10 # only needed for koka-test - isocline-1.0.7 rebuild-ghc-options: true diff --git a/test/cgen/specialize/branch.kk b/test/cgen/specialize/branch.kk index 8cce54492..1eeab5caa 100644 --- a/test/cgen/specialize/branch.kk +++ b/test/cgen/specialize/branch.kk @@ -5,7 +5,7 @@ fun map_other(xs : list, f : a -> b, g : a -> b) : list { // this branch gets specialized Cons(x, xx) | isEven -> Cons(f(x), xx.map_other(f, g)) // this branch does not since f and g are passed in a different order - | _ -> Cons(g(x), xx.map_other(g, f)) + | True -> Cons(g(x), xx.map_other(g, f)) } } diff --git a/util/install.bat b/util/install.bat index 9cd61fde5..d337f5331 100644 --- a/util/install.bat +++ b/util/install.bat @@ -4,7 +4,7 @@ rem Installation script for Koka; use -h to see command line options. rem ------------------------------------------------------------------ setlocal -set KOKA_VERSION=v2.4.0 +set KOKA_VERSION=v2.4.2 set KOKA_PREFIX=%LOCALAPPDATA%\koka set KOKA_UNINSTALL=N set KOKA_HELP=N diff --git a/util/install.sh b/util/install.sh index 936530f7c..0e3e5ddfc 100755 --- a/util/install.sh +++ b/util/install.sh @@ -4,7 +4,7 @@ # Installation script for Koka; use -h to see command line options. #----------------------------------------------------------------------------- -VERSION="v2.4.0" +VERSION="v2.4.2" MODE="install" # or uninstall PREFIX="/usr/local" QUIET="" diff --git a/util/minbuild.sh b/util/minbuild.sh index b36823e8a..b2604e59e 100755 --- a/util/minbuild.sh +++ b/util/minbuild.sh @@ -5,7 +5,7 @@ # For use on platforms where stack is not working and to document # the minimal needed commands to build the full compiler. -KOKA_VERSION=2.4.0 +KOKA_VERSION=2.4.2 KOKA_VARIANT=release echo "" From b76ecf3b856bcbbe4da784d79e57bc662c63256d Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 17:52:20 -0700 Subject: [PATCH 222/233] allow for reference iso types; fix tests --- src/Kind/Repr.hs | 6 +++--- test/cgen/ctail7a.kk | 4 ++-- test/cgen/ctail7c.kk | 4 ++-- test/cgen/javascript.kk.out | 3 ++- test/cgen/rec5.kk.out | 1 - test/cgen/specialize/maptwice.kk.out | 8 ++++---- test/cgen/specialize/tree-list.kk.out | 16 ++++++++-------- test/kind/type3.kk.out | 2 ++ test/medium/garcia-wachs.kk | 2 +- test/parc/parc2.kk.out | 2 +- test/parc/parc22.kk.out | 10 +++++++--- test/static/wrong/duplicate3.kk | 2 +- test/static/wrong/duplicate3.kk.out | 2 +- test/type/args1.kk | 2 +- test/type/warn1.kk | 2 +- test/type/warn1.kk.out | 1 - 16 files changed, 36 insertions(+), 31 deletions(-) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index ef355fd2c..298c0dfdc 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -55,8 +55,8 @@ createDataDef emitError emitWarning lookupDataInfo case dd of {- DataDefValue vr | isEnum -- allow allocated enum types -> return dd -} - DataDefValue vr | isIso -- iso types are always value types - -> return dd + {- DataDefValue vr | isIso -- iso types are always value types + -> return dd -} _ -> return DataDefNormal DataDefAuto | isRec @@ -66,7 +66,7 @@ createDataDef emitError emitWarning lookupDataInfo case dd of DataDefValue vr | isEnum -> return dd - DataDefValue vr | isIso -- iso types are always value types + DataDefValue vr | isIso -- iso types are preferred as value types -> return dd DataDefValue vr -> do let wouldGetTagField = (conCount > 1 && not isEnum) diff --git a/test/cgen/ctail7a.kk b/test/cgen/ctail7a.kk index 09e4f66c2..1296da286 100644 --- a/test/cgen/ctail7a.kk +++ b/test/cgen/ctail7a.kk @@ -3,8 +3,8 @@ type tree Tip Node( left : ind, right : ind ) -reference type ind - Ind( ind : a ) +ref type ind + Ind( ind : a) fun make( depth : int ) : tree if depth > 0 then diff --git a/test/cgen/ctail7c.kk b/test/cgen/ctail7c.kk index 2bb4c5f54..2aeaa6c3b 100644 --- a/test/cgen/ctail7c.kk +++ b/test/cgen/ctail7c.kk @@ -3,8 +3,8 @@ type tree Tip Node( left : ind, right : ind ) -reference type ind - Ind( ind : a ) +ref type ind + Ind( ind : a) fun make( depth : int ) : console tree if depth > 0 then diff --git a/test/cgen/javascript.kk.out b/test/cgen/javascript.kk.out index ae9a6e8d2..0e3c901be 100644 --- a/test/cgen/javascript.kk.out +++ b/test/cgen/javascript.kk.out @@ -1,4 +1,5 @@ 3add default effect for std/core/exn -test/cgen/javascript.kk(84, 3): warning: Some branches in the match will never be reached: _ +test/cgen/javascript.kk(81, 1): warning: Type person may be better declared as a value type for efficiency (e.g. 'value type/struct'), + or declared as a reference type to suppress this warning (e.g. 'ref type/struct') test/cgen/javascript.kk(84, 3): warning: Some branches in the match will never be reached: _ \ No newline at end of file diff --git a/test/cgen/rec5.kk.out b/test/cgen/rec5.kk.out index a6f694b50..42562f7ac 100644 --- a/test/cgen/rec5.kk.out +++ b/test/cgen/rec5.kk.out @@ -1,4 +1,3 @@ 1add default effect for std/core/exn -test/cgen/rec5.kk(2,13): warning: xs shadows an earlier local definition or parameter test/cgen/rec5.kk(2,13): warning: xs shadows an earlier local definition or parameter \ No newline at end of file diff --git a/test/cgen/specialize/maptwice.kk.out b/test/cgen/specialize/maptwice.kk.out index cb39f3e2e..f81a5f1e5 100644 --- a/test/cgen/specialize/maptwice.kk.out +++ b/test/cgen/specialize/maptwice.kk.out @@ -2,10 +2,10 @@ add default effect for std/core/exn cgen/specialize/maptwice/.hmain: () -> console () -cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs618 : list>) -> total list> -cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs623 : list>) -> total list> -cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs631 : list>) -> total list> -cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs636 : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs666 : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs671 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs679 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs684 : list>) -> total list> cgen/specialize/maptwice/.mlift000-main: (int) -> exn () cgen/specialize/maptwice/.mlift000-main: (list) -> exn () cgen/specialize/maptwice/main: () -> () diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index 6333ce066..3de48545a 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -1,15 +1,15 @@ Tree(2, [Tree(3, []), Tree(4, [])]) cgen/specialize/tree-list/.copy: forall (tree, data : optional, children : optional>>) -> tree -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1147 : list>) -> list> -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1152 : list>) -> list> -cgen/specialize/tree-list/.lift000-show: (xs1160 : list>) -> div list -cgen/specialize/tree-list/.lift000-show: (xs1165 : list>) -> div list +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1187 : list>) -> list> +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1192 : list>) -> list> +cgen/specialize/tree-list/.lift000-show: (xs1200 : list>) -> div list +cgen/specialize/tree-list/.lift000-show: (xs1205 : list>) -> div list cgen/specialize/tree-list/.lift000-main: (tree) -> tree -cgen/specialize/tree-list/.lift000-main: (xs1179 : list>) -> list> -cgen/specialize/tree-list/.lift000-main: (xs1184 : list>) -> list> -cgen/specialize/tree-list/.mlift000-lift1192-mapT: forall (tree, list>) -> list> -cgen/specialize/tree-list/.mlift000-lift1192-mapT: forall (f : (a) -> b, xx1156 : list>, tree) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1219 : list>) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1224 : list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1232-mapT: forall (tree, list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1232-mapT: forall (f : (a) -> b, xx1196 : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> diff --git a/test/kind/type3.kk.out b/test/kind/type3.kk.out index b3ffd8e4d..442b5c054 100644 --- a/test/kind/type3.kk.out +++ b/test/kind/type3.kk.out @@ -1 +1,3 @@ +test/kind/type3.kk(1, 1): warning: Type maybe may be better declared as a value type for efficiency (e.g. 'value type/struct'), + or declared as a reference type to suppress this warning (e.g. 'ref type/struct') kind/type3/maybe: V -> V \ No newline at end of file diff --git a/test/medium/garcia-wachs.kk b/test/medium/garcia-wachs.kk index 40870e92f..270db94a5 100644 --- a/test/medium/garcia-wachs.kk +++ b/test/medium/garcia-wachs.kk @@ -24,7 +24,7 @@ fun show( t : tree ) : string //---------------------------------------------------- // Non empty lists //---------------------------------------------------- -pub type list1 { +pub ref type list1 { Cons1( head : a, tail : list ) } diff --git a/test/parc/parc2.kk.out b/test/parc/parc2.kk.out index 1bd0122d0..827d08bf9 100644 --- a/test/parc/parc2.kk.out +++ b/test/parc/parc2.kk.out @@ -7,6 +7,6 @@ pub fun test : forall (x : list) -> list (std/core/Nil() : (list) ) -> x; _ - -> std/core/.unroll17080-append((std/core/types/.dup(x)), x); + -> std/core/.unroll17330-append((std/core/types/.dup(x)), x); }; }; \ No newline at end of file diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index 0aacdeb92..37570db21 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -24,7 +24,9 @@ pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/he = std/core/types/.drop(.this, (std/core/int32(1))); .i; (.skip std/core/types/None() : (optional) ) - -> (match (.this) { + -> val _ : () + = std/core/types/.drop(i0); + (match (.this) { (.skip parc/parc22/World((.x: int)) : parc/parc22/hello ) -> val _ : () = (match ((std/core/types/.is-unique(.this))) { @@ -47,7 +49,9 @@ pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/he }; pub fun f : (h : parc/parc22/hello) -> parc/parc22/hello = fn(h: parc/parc22/hello){ + val .ru : reuse + = std/core/types/no-reuse(); val _ : () - = std/core/types/.drop(h, (std/core/int32(1))); - parc/parc22/World(2); + = std/core/types/.assign-reuse(.ru, (std/core/types/.drop-reuse(h, (std/core/int32(1))))); + std/core/types/.alloc-at(.ru, (parc/parc22/World(2))); }; \ No newline at end of file diff --git a/test/static/wrong/duplicate3.kk b/test/static/wrong/duplicate3.kk index f10060448..fae218c44 100644 --- a/test/static/wrong/duplicate3.kk +++ b/test/static/wrong/duplicate3.kk @@ -1,2 +1,2 @@ // duplicate constructor -type dup { Dup1(:int); Dup1(:int) } +ref type dup { Dup1(:int); Dup1(:int) } diff --git a/test/static/wrong/duplicate3.kk.out b/test/static/wrong/duplicate3.kk.out index 0eb3a5d12..60327f1c3 100644 --- a/test/static/wrong/duplicate3.kk.out +++ b/test/static/wrong/duplicate3.kk.out @@ -1 +1 @@ -test/static/wrong/duplicate3.kk(2,25): error: Constructor static/wrong/duplicate3/Dup1 is already defined at (2,13) \ No newline at end of file +test/static/wrong/duplicate3.kk(2,29): error: Constructor static/wrong/duplicate3/Dup1 is already defined at (2,17) \ No newline at end of file diff --git a/test/type/args1.kk b/test/type/args1.kk index c1858e0fd..17f811bc0 100644 --- a/test/type/args1.kk +++ b/test/type/args1.kk @@ -1,4 +1,4 @@ -struct test( x : int, y : int = 0 ) +value struct test( x : int, y : int = 0 ) fun foo() { Test(1) diff --git a/test/type/warn1.kk b/test/type/warn1.kk index 6153ac719..0ed952fd4 100644 --- a/test/type/warn1.kk +++ b/test/type/warn1.kk @@ -2,7 +2,7 @@ fun f(xs) { fun len(xs) { match(xs) { - Cons(_,xs) -> len(xs) + Cons(_,xx) -> len(xx) _ -> 0 } } diff --git a/test/type/warn1.kk.out b/test/type/warn1.kk.out index 43176228d..2b3e20056 100644 --- a/test/type/warn1.kk.out +++ b/test/type/warn1.kk.out @@ -1,3 +1,2 @@ test/type/warn1.kk(3,11): warning: xs shadows an earlier local definition or parameter -test/type/warn1.kk(5,14): warning: xs shadows an earlier local definition or parameter type/warn1/f: forall (xs : list) -> int \ No newline at end of file From e1b39f6e6e36e2feef5b3e29884683f430e8938e Mon Sep 17 00:00:00 2001 From: daanx Date: Wed, 28 Jun 2023 21:38:13 -0700 Subject: [PATCH 223/233] wip: add context path info to constructors in Core --- kklib/include/kklib.h | 42 ++++++++++++++++++++-------------- kklib/src/refcount.c | 2 +- kklib/src/string.c | 4 ++-- lib/std/core.kk | 2 +- lib/std/core/core-inline.c | 6 ++--- lib/std/core/hnd-inline.c | 1 + lib/std/core/types.kk | 2 +- lib/std/text/regex-inline.c | 12 +++++----- src/Backend/C/Box.hs | 2 +- src/Backend/C/FromCore.hs | 24 ++++++++++++++----- src/Backend/CSharp/FromCore.hs | 10 ++++---- src/Core/Core.hs | 36 +++++++++++++++++++++-------- 12 files changed, 91 insertions(+), 52 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index d54e7a3f4..b1c40f99c 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 110 // modify on changes to trigger recompilation +#define KKLIB_BUILD 111 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -115,26 +115,31 @@ static inline kk_refcount_t kk_refcount_inc(kk_refcount_t rc) { return (kk_refcount_t)((uint32_t)rc + 1); } +// context path index +typedef int kk_cpath_t; +#define KK_CPATH_MAX (0xFF) + // Every heap block starts with a 64-bit header with a reference count, tag, and scan fields count. // If the scan_fsize == 0xFF, the full scan count is in the first field as a boxed int (which includes the scan field itself). typedef struct kk_header_s { uint8_t scan_fsize; // number of fields that should be scanned when releasing (`scan_fsize <= 0xFF`, if 0xFF, the full scan size is the first field) - uint8_t _field_idx; // private: only used during stack-less freeing and marking (see `refcount.c`) + uint8_t _field_idx; // private: used for context paths and during stack-less freeing (see `refcount.c`) uint16_t tag; // constructor tag _Atomic(kk_refcount_t) refcount; // reference count (last to reduce code size constants in kk_header_init) } kk_header_t; #define KK_SCAN_FSIZE_MAX (0xFF) -#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(0) } // start with unique refcount +#define KK_HEADER(scan_fsize,fidx,tag) { scan_fsize, fidx, tag, KK_ATOMIC_VAR_INIT(0) } // start with unique refcount #define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(INT32_MIN) } // start with a stuck refcount (RC_STUCK) -static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_assert_internal(scan_fsize >= 0 && scan_fsize <= KK_SCAN_FSIZE_MAX); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); #if (KK_ARCH_LITTLE_ENDIAN && !defined(__aarch64__)) - *((uint64_t*)h) = ((uint64_t)scan_fsize | (uint64_t)tag << 16); // explicit shifts leads to better codegen in general + *((uint64_t*)h) = ((uint64_t)scan_fsize | ((uint64_t)cpath << 8) | ((uint64_t)tag << 16)); // explicit shifts leads to better codegen in general #else - kk_header_t header = KK_HEADER((uint8_t)scan_fsize, (uint16_t)tag); + kk_header_t header = KK_HEADER((uint8_t)scan_fsize, (uint8_t)cpath, (uint16_t)tag); *h = header; #endif } @@ -569,18 +574,20 @@ static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { } #endif -static inline void kk_block_init(kk_block_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_block_init(kk_block_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_unused(size); kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); - kk_header_init(&b->header, scan_fsize, tag); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); + kk_header_init(&b->header, scan_fsize, cpath, tag); } -static inline void kk_block_large_init(kk_block_large_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_block_large_init(kk_block_large_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_unused(size); // to optimize for "small" vectors with less than 255 scanable elements, we still set the small scan_fsize // for those in the header. This is still duplicated in the large scan_fsize field as it is used for the vector length for example. + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); uint8_t bscan_fsize = (scan_fsize >= KK_SCAN_FSIZE_MAX ? KK_SCAN_FSIZE_MAX : (uint8_t)scan_fsize); - kk_header_init(&b->_block.header, bscan_fsize, tag); + kk_header_init(&b->_block.header, bscan_fsize, cpath, tag); kk_assert_internal(scan_fsize > 0); kk_assert_internal(scan_fsize <= KK_INTF_MAX); b->large_scan_fsize = kk_intf_box((kk_intf_t)scan_fsize); @@ -590,8 +597,9 @@ typedef kk_block_t* kk_reuse_t; #define kk_reuse_null ((kk_reuse_t)NULL) -static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { +static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); kk_block_t* b; if (at==kk_reuse_null) { b = (kk_block_t*)kk_malloc_small(size, ctx); @@ -600,27 +608,27 @@ static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_s kk_assert_internal(kk_block_is_unique(at)); // TODO: check usable size of `at` b = at; } - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, cpath, tag); return b; } static inline kk_block_t* kk_block_alloc(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); kk_block_t* b = (kk_block_t*)kk_malloc_small(size, ctx); - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, 0, tag); return b; } static inline kk_block_t* kk_block_alloc_any(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); kk_block_t* b = (kk_block_t*)kk_malloc(size, ctx); - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, 0, tag); return b; } static inline kk_block_large_t* kk_block_large_alloc(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_block_large_t* b = (kk_block_large_t*)kk_malloc(size, ctx); - kk_block_large_init(b, size, scan_fsize, tag); + kk_block_large_init(b, size, scan_fsize, 0, tag); return b; } @@ -640,8 +648,8 @@ static inline void kk_block_free(kk_block_t* b, kk_context_t* ctx) { kk_free(b, ctx); } -#define kk_block_alloc_as(struct_tp,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc_at(kk_reuse_null, sizeof(struct_tp),scan_fsize,tag,ctx)) -#define kk_block_alloc_at_as(struct_tp,at,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc_at(at, sizeof(struct_tp),scan_fsize,tag,ctx)) +#define kk_block_alloc_as(struct_tp,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc( sizeof(struct_tp),scan_fsize,tag,ctx)) +#define kk_block_alloc_at_as(struct_tp,at,scan_fsize,cpath,tag,ctx) ((struct_tp*)kk_block_alloc_at(at, sizeof(struct_tp),scan_fsize,cpath,tag,ctx)) #define kk_block_as(tp,b) ((tp)((void*)(b))) #define kk_block_assert(tp,b,tag) ((tp)kk_block_assertx(b,tag)) diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index a1f1910cd..8be9481c4 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -163,7 +163,7 @@ kk_decl_noinline kk_reuse_t kk_block_check_drop_reuse(kk_block_t* b, kk_refcount for (kk_ssize_t i = 0; i < scan_fsize; i++) { kk_box_drop(kk_block_field(b, i), ctx); } - kk_header_init(&b->header,0,KK_TAG_INVALID); // not really necessary + kk_header_init(&b->header,0,0,KK_TAG_INVALID); // not really necessary return b; } else { diff --git a/kklib/src/string.c b/kklib/src/string.c index 6ea74efa4..c15e18a6a 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -210,8 +210,8 @@ kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count) { c = KK_RAW_UTF8_OFS + b; } #if (DEBUG!=0) - kk_ssize_t dcount = 0; - kk_ssize_t vcount = 0; + kk_ssize_t dcount; + kk_ssize_t vcount; kk_assert_internal(c == kk_utf8_read_validate(s, &dcount, &vcount, false)); kk_assert_internal(*count == dcount); #endif diff --git a/lib/std/core.kk b/lib/std/core.kk index 36bbf1f08..d23a94a23 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -184,7 +184,7 @@ pub fun map( e : either, f : b -> e c ) : e either // by a list (`Cons`). pub type list // The empty list. - con Nil + con Nil // note: must come first; see Core/Core.hs // A ``head`` element followed by the ``tail`` of the list. con Cons(head:a, tail : list ) diff --git a/lib/std/core/core-inline.c b/lib/std/core/core-inline.c index 93765baa6..3a5f690bc 100644 --- a/lib/std/core/core-inline.c +++ b/lib/std/core/core-inline.c @@ -19,7 +19,7 @@ kk_std_core__list kk_vector_to_list(kk_vector_t v, kk_std_core__list tail, kk_co struct kk_std_core_Cons* cons = NULL; kk_std_core__list list = kk_std_core__new_Nil(ctx); for( kk_ssize_t i = 0; i < n; i++ ) { - kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,kk_box_dup(p[i],ctx), nil, ctx); + kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,0,kk_box_dup(p[i],ctx), nil, ctx); if (cons==NULL) { list = hd; } @@ -84,7 +84,7 @@ kk_std_core__list kk_string_to_list(kk_string_t s, kk_context_t* ctx) { while( p < end ) { kk_char_t c = kk_utf8_read(p,&count); p += count; - kk_std_core__list cons = kk_std_core__new_Cons(kk_reuse_null,kk_char_box(c,ctx), nil, ctx); + kk_std_core__list cons = kk_std_core__new_Cons(kk_reuse_null,0,kk_char_box(c,ctx), nil, ctx); if (tl!=NULL) { tl->tail = cons; } @@ -343,7 +343,7 @@ kk_std_core__error kk_error_from_errno( int err, kk_context_t* ctx ) { // Old style msg = kk_string_alloc_from_qutf8( strerror(err), ctx ); #endif - return kk_std_core__new_Error( kk_std_core__new_Exception( msg, kk_std_core__new_ExnSystem(kk_reuse_null, kk_integer_from_int(err,ctx), ctx), ctx), ctx ); + return kk_std_core__new_Error( kk_std_core__new_Exception( msg, kk_std_core__new_ExnSystem(kk_reuse_null, 0, kk_integer_from_int(err,ctx), ctx), ctx), ctx ); } diff --git a/lib/std/core/hnd-inline.c b/lib/std/core/hnd-inline.c index ca65fc0d2..33b46cd27 100644 --- a/lib/std/core/hnd-inline.c +++ b/lib/std/core/hnd-inline.c @@ -49,6 +49,7 @@ kk_std_core_hnd__ev kk_ev_none(kk_context_t* ctx) { if (kk_datatype_is_null(ev_none_singleton)) { ev_none_singleton = kk_std_core_hnd__new_Ev( kk_reuse_null, + 0, // cpath kk_std_core_hnd__new_Htag(kk_string_empty(),ctx), // tag "" kk_std_core_hnd__new_Marker(0,ctx), // marker 0 kk_box_null(), // no handler diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index cedc8aa33..a85461495 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -20,7 +20,7 @@ pub infixr 55 (++.) pub infixr 30 (&&) pub infixr 20 (||) -// build: 108 +// build: 111 // ---------------------------------------------------------------------------- // Core types diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index 185e6cdde..5eda893e8 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -120,7 +120,7 @@ static kk_std_core__list kk_regex_exec_ex( pcre2_code* re, pcre2_match_data* mat kk_ssize_t send = groups[i*2 + 1]; kk_assert(send >= sstart); kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow,ctx), kk_integer_from_ssize_t(sstart,ctx), kk_integer_from_ssize_t(send - sstart,ctx), ctx ); - hd = kk_std_core__new_Cons(kk_reuse_null,kk_std_core__sslice_box(sslice,ctx), hd, ctx); + hd = kk_std_core__new_Cons(kk_reuse_null,0,kk_std_core__sslice_box(sslice,ctx), hd, ctx); if (i == 0) { if (mstart != NULL) { *mstart = sstart; } if (end != NULL) { *end = send; } @@ -184,9 +184,9 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss // found a match; // push string up to match, and the actual matched regex kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(start,ctx), kk_integer_from_ssize_t(mstart - start,ctx), ctx ); - kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); - kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); - kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(prelist,ctx), capcons, ctx ); + kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); + kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(prelist,ctx), capcons, ctx ); if (tail==NULL) res = cons; else *tail = cons; tail = &kk_std_core__as_Cons(capcons,ctx)->tail; @@ -205,8 +205,8 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss // push final string part as well and end the list kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(next,ctx), kk_integer_from_ssize_t(len - next,ctx), ctx ); - kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); - kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); if (tail==NULL) res = cons; else *tail = cons; } diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index 18e47608a..886e4e3a4 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -390,7 +390,7 @@ patBox tpPat tpRes pat = PatCon (TName nameBoxCon (conInfoType boxConInfo)) [pat] boxConRepr [tpPat] [] tpRes boxConInfo True boxConRepr :: ConRepr -boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) 0 +boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) 0 0 boxConInfo :: ConInfo boxConInfo diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 83ce27aa5..e8f08bb47 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -650,10 +650,13 @@ genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount -} when (dataRepr == DataOpen) $ emitToH $ text "extern kk_string_t" <+> conTagName con <.> semi let at = newHiddenName "at" + cpath = newHiddenName "cpath" + hasCPath = conReprHasCtxPath conRepr && not (null allFields) (paddingFields,conFields) = partition (isPaddingName . fst) allFields emitToH $ text "static inline" <+> ppName (typeClassName (dataInfoName info)) <+> conCreateNameInfo con <.> ntparameters ((if (dataReprIsValue dataRepr || (null conFields) || isDataAsMaybe dataRepr) then [] else [(at,typeReuse)]) + ++ (if hasCPath then [(cpath,typeInt32)] else []) ++ conInfoParams con) <+> block ( let nameDoc = ppName (conInfoName con) @@ -695,9 +698,11 @@ genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount <.> arguments [ text "struct" <+> nameDoc, (if (isDataAsMaybe dataRepr || null conFields {- open singleton -}) then text "kk_reuse_null" else ppName at), pretty scanCount <+> text "/* scan count */", + (if hasCPath then ppName cpath else text "0"), if (dataRepr /= DataOpen) - then ppConTag con conRepr dataRepr - else text "KK_TAG_OPEN"] + then ppConTag con conRepr dataRepr + else text "KK_TAG_OPEN" + ] <.> semi] ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> arguments [ppConTag con conRepr dataRepr] <.> semi ]) ++ map (assignField (\fld -> tmp <.> text "->" <.> fld)) conFields @@ -1881,11 +1886,11 @@ genAppNormal :: Expr -> [Expr] -> Asm ([Doc],Doc) genAppNormal (Var allocAt _) [Var at _, App (Con tname repr) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr (null args) ++ argDocs)) genAppNormal (Var allocAt _) [Var at _, App (TypeApp (Con tname repr) targs) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr (null args) ++ argDocs)) genAppNormal v@(Var allocAt _) [at, Let dgs expr] | getName allocAt == nameAllocAt -- can happen due to box operations = genExpr (Let dgs (App v [at,expr])) @@ -1953,8 +1958,8 @@ genAppNormal f args -> case f of -- constructor Con tname repr - -> let at = if (dataReprIsValue (conDataRepr repr) || isConAsJust repr) then [] else [text "kk_reuse_null"] - in return (decls,conCreateName (getName tname) <.> arguments (at ++ argDocs)) + -> let at = if (dataReprIsValue (conDataRepr repr) || isConAsJust repr) then [] else [text "kk_reuse_null"] + in return (decls,conCreateName (getName tname) <.> arguments (at ++ ppCtxPath repr (null argDocs) ++ argDocs)) -- call to known function Var tname _ | getName tname == nameAllocAt -> failure ("Backend.C.genApp.Var.allocat: " ++ show (f,args)) @@ -1973,6 +1978,13 @@ genAppNormal f args _ -> failure $ ("Backend.C.genAppNormal: expecting function type: " ++ show (pretty (typeOf f))) return (fdecls ++ decls, text "kk_function_call" <.> arguments [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) +ppCtxPath :: ConRepr -> Bool -> [Doc] +ppCtxPath repr True = [] +ppCtxPath repr noArgs + = case conReprCtxPath repr of + Just cpath -> [pretty cpath] + _ -> [] + -- Assign fields to a constructor. Used in: genAppNormal on conAssignFields genAssignFields :: Doc -> TName -> TName -> [Name] -> [Expr] -> Asm ([Doc], Doc, [Doc], Doc) diff --git a/src/Backend/CSharp/FromCore.hs b/src/Backend/CSharp/FromCore.hs index 5e7799891..f7e99a5e8 100644 --- a/src/Backend/CSharp/FromCore.hs +++ b/src/Backend/CSharp/FromCore.hs @@ -208,7 +208,7 @@ genConstructor info dataRepr (con,conRepr) = -> assertion ("CSharp.FromCore.genTypeDef: singleton constructor with existentials?") (null (conInfoExists con)) $ conSingleton typeName - ConAsCons typeName _ _ nilName _ + ConAsCons typeName _ _ nilName _ _ -> -- merge it into the type class itself do ctx <- getModule putLn (vcat (map (ppConField ctx) (conInfoParams con) ++ ppConConstructor ctx con conRepr [])) @@ -302,7 +302,7 @@ ppConConstructorEx ctx con conRepr conParams defaults then [] else [text "public" <+> (case conRepr of - ConAsCons typeName _ _ nilName _ -> ppDefName (typeClassName typeName) + ConAsCons typeName _ _ nilName _ _ -> ppDefName (typeClassName typeName) ConSingle{conTypeName=typeName} -> ppDefName (typeClassName typeName) ConStruct{conTypeName=typeName} -> ppDefName (typeClassName typeName) ConIso {conTypeName=typeName} -> ppDefName (typeClassName typeName) @@ -1156,7 +1156,7 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) ConSingleton typeName _ _ _ -> assertion "CSharp.FromCore.ppPatternTest.singleton with patterns?" (null patterns) $ return [(test [exprDoc <+> text "==" <+> ppConSingleton ctx typeName tname tpars],[],[],[])] - ConSingle typeName _ _ _ + ConSingle typeName _ _ _ _ -> -- assertion ("CSharp.FromCore.ppPatternTest.single with test? ") (doTest == False) $ -- note: the assertion can happen when a nested singleton is tested do -- generate local for the test result @@ -1166,7 +1166,7 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) return [([] -- test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) targs] ,[],next,[])] - ConAsCons typeName _ _ nilName _ + ConAsCons typeName _ _ nilName _ _ -> do let next = genNextPatterns (exprDoc) (typeOf tname) patterns return [(test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) tpars] @@ -1177,7 +1177,7 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) -> testStruct typeName ConIso typeName _ _ _ -> testStruct typeName - ConNormal typeName _ _ _ + ConNormal typeName _ _ _ _ -> conTest ctx typeName exists -- TODO: use tags if available ConOpen{conTypeName=typeName} -> conTest ctx typeName exists diff --git a/src/Core/Core.hs b/src/Core/Core.hs index e18bb44d2..5aac29866 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -66,6 +66,7 @@ module Core.Core ( -- Data structures , isConSingleton , isConNormal , isConIso, isConAsJust + , conReprHasCtxPath, conReprCtxPath , isDataStruct, isDataAsMaybe, isDataStructAsMaybe , conReprAllocSize, conReprAllocSizeScan, conReprScanCount , getDataRepr, getDataReprEx, dataInfoIsValue @@ -180,7 +181,7 @@ makeList tp exprs nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList valueReprZero 0) nil = TypeApp nilCon [tp] consTp = TForall [a] [] (typeFun [(nameNil,TVar a),(nameNil,TApp typeList [TVar a])] typeTotal (TApp typeList [TVar a])) - consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull 2) -- NOTE: depends on Cons being second in the definition in std/core :-( + consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull 2 0) -- NOTE: depends on Cons being second in the definition in std/core :-( cons expr xs = App (TypeApp consCon [tp]) [expr,xs] a = TypeVar (0) kindStar Bound @@ -368,12 +369,12 @@ data DataRepr = -- value types data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- part of enumeration (none has fields) | ConIso{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- one constructor with one field | ConSingleton{conTypeName::Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor without fields (and not part of an enum) - | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) + | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor as value type - | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) - | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr } -- constructor of open data type - | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- a regular constructor + | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conCtxPath :: Int, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) + | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int } -- constructor of open data type + | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int, conTag :: Int } -- a regular constructor deriving (Eq,Ord,Show) isConSingleton (ConSingleton{}) = True @@ -397,6 +398,23 @@ isDataStructAsMaybe _ = False isConAsJust (ConAsJust{}) = True isConAsJust _ = False +conReprHasCtxPath :: ConRepr -> Bool +conReprHasCtxPath repr + = case conReprCtxPath repr of + Nothing -> False + _ -> True + +conReprCtxPath :: ConRepr -> Maybe Int +conReprCtxPath repr | conReprIsValue repr = Nothing +conReprCtxPath repr + = case repr of + ConSingle{ conCtxPath = cpath } -> Just cpath + ConAsCons{ conCtxPath = cpath } -> Just cpath + ConNormal{ conCtxPath = cpath } -> Just cpath + ConOpen{ conCtxPath = cpath } -> Just cpath + _ -> Nothing + + conReprScanCount :: ConRepr -> Int conReprScanCount conRepr = valueReprScanCount (conValRepr conRepr) @@ -447,7 +465,7 @@ getDataReprEx getIsValue info isValue = getIsValue info && not (dataInfoIsRec info) (dataRepr,conReprFuns) = if (dataInfoIsOpen(info)) - then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo)) conInfos) + then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo) 0) conInfos) -- TODO: only for C#? check this during kind inference? -- else if (hasExistentials) -- then (DataNormal, map (\con -> ConNormal typeName) conInfos) @@ -466,7 +484,7 @@ getDataReprEx getIsValue info in (dataRepr ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr valRepr else if length singletons == 1 then ConSingleton typeName dataRepr valRepr - else ConSingle typeName dataRepr valRepr]) + else ConSingle typeName dataRepr valRepr 0]) else if (isValue && not (dataInfoIsRec info)) then ( let dataRepr = if (length conInfos == 2 && length singletons == 1 && case (filter (\cinfo -> length (conInfoParams cinfo) == 1) conInfos) of -- at most 1 field @@ -495,7 +513,7 @@ getDataReprEx getIsValue info else (DataAsList ,map (\ci tag -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsList (conInfoValueRepr ci) tag - else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) tag) conInfos) + else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) tag 0) conInfos) ) else let dataRepr = if (length singletons == length conInfos -1 || null conInfos) @@ -503,7 +521,7 @@ getDataReprEx getIsValue info in (dataRepr ,map (\ci -> if null (conInfoParams ci) then ConSingleton typeName dataRepr (conInfoValueRepr ci) - else ConNormal typeName dataRepr (conInfoValueRepr ci)) conInfos + else ConNormal typeName dataRepr (conInfoValueRepr ci) 0) conInfos ) ) in (dataRepr, [conReprFun tag | (conReprFun,tag) <- zip conReprFuns [1..]]) From 901ffdee6c1ff49fe34751391814530c14c7240d Mon Sep 17 00:00:00 2001 From: Daan Date: Thu, 29 Jun 2023 10:34:49 -0700 Subject: [PATCH 224/233] wip: improve context path generation --- kklib/include/kklib.h | 18 ++++++++++++++- lib/std/core/types.kk | 2 +- src/Backend/C/Box.hs | 2 +- src/Backend/C/FromCore.hs | 42 +++++++++++++++++++++------------- src/Backend/C/ParcReuseSpec.hs | 22 +++++++++--------- src/Core/AnalysisCCtx.hs | 26 +++++++++++---------- src/Core/Core.hs | 31 +++++++++++++------------ 7 files changed, 87 insertions(+), 56 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index b1c40f99c..28a59ad3a 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 111 // modify on changes to trigger recompilation +#define KKLIB_BUILD 112 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes @@ -1310,6 +1310,21 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) Constructor contexts (Further primitives are defined in `lib/std/core/types-cctx-inline.h`) --------------------------------------------------------------------------------------*/ +#define kk_field_index_of(contp,field_name) kk_field_index_at(offsetof(contp,field_name)) + +static inline kk_cpath_t kk_field_index_at( size_t field_offset ) { + kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); + const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); + kk_assert_internal(field_index <= KK_SCAN_FSIZE_MAX - 2); + return (kk_cpath_t)(1 + field_index); +} + +#define kk_set_cpath(contp,con,field_name) kk_set_cpath_at( &(con)->_base._block, kk_field_index_of(contp,field_name) ) +static inline void kk_set_cpath_at( kk_block_t* b, kk_cpath_t cpath ) { + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); + b->header._field_idx = (uint8_t)cpath; + } + #if !defined(KK_HAS_MALLOC_COPY) #define KK_CCTX_NO_CONTEXT_PATH #else @@ -1317,6 +1332,7 @@ static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) // functional context application by copying along the context path and attaching `child` at the hole. kk_decl_export kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t* holeptr, kk_box_t child, kk_context_t* ctx); +// depricated: // set the context path. // update the field_idx with the field index + 1 that is along the context path, and return `d` as is. static inline kk_datatype_t kk_cctx_setcp(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index a85461495..10772f6cc 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -20,7 +20,7 @@ pub infixr 55 (++.) pub infixr 30 (&&) pub infixr 20 (||) -// build: 111 +// build: 112 // ---------------------------------------------------------------------------- // Core types diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index 886e4e3a4..be945bcbd 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -390,7 +390,7 @@ patBox tpPat tpRes pat = PatCon (TName nameBoxCon (conInfoType boxConInfo)) [pat] boxConRepr [tpPat] [] tpRes boxConInfo True boxConRepr :: ConRepr -boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) 0 0 +boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) CtxNone 0 boxConInfo :: ConInfo boxConInfo diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index e8f08bb47..c283d5175 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1886,30 +1886,30 @@ genAppNormal :: Expr -> [Expr] -> Asm ([Doc],Doc) genAppNormal (Var allocAt _) [Var at _, App (Con tname repr) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr (null args) ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr tname (null args) ++ argDocs)) genAppNormal (Var allocAt _) [Var at _, App (TypeApp (Con tname repr) targs) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr (null args) ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr tname (null args) ++ argDocs)) genAppNormal v@(Var allocAt _) [at, Let dgs expr] | getName allocAt == nameAllocAt -- can happen due to box operations = genExpr (Let dgs (App v [at,expr])) -- special: conAssignFields -genAppNormal (Var (TName conTagFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName nameNil):(Var tag _):fieldValues) | conTagFieldsAssign == nameConTagFieldsAssign +genAppNormal (Var (TName conTagFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName conRepr nameNil):(Var tag _):fieldValues) | conTagFieldsAssign == nameConTagFieldsAssign = do tmp <- genVarName "con" let setTag = tmp <.> text "->_base._block.header.tag = (kk_tag_t)" <.> parens (text (show tag)) <.> semi fieldNames = case splitFunScheme typeAssign of Just (_,_,args,_,_) -> tail (tail (map fst args)) _ -> failure ("Backend.C.FromCore: illegal conAssignFields type: " ++ show (pretty typeAssign)) - (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName reuseName fieldNames fieldValues + (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName conRepr reuseName fieldNames fieldValues return (decls ++ [tmpDecl, setTag] ++ assigns, result) -genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName nameNil):fieldValues) | conFieldsAssign == nameConFieldsAssign +genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName conRepr nameNil):fieldValues) | conFieldsAssign == nameConFieldsAssign = do tmp <- genVarName "con" let fieldNames = case splitFunScheme typeAssign of Just (_,_,args,_,_) -> tail (map fst args) _ -> failure ("Backend.C.FromCore: illegal conAssignFields type: " ++ show (pretty typeAssign)) - (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName reuseName fieldNames fieldValues + (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName conRepr reuseName fieldNames fieldValues return (decls ++ [tmpDecl] ++ assigns, result) -- special: cfield-hole @@ -1959,7 +1959,7 @@ genAppNormal f args -- constructor Con tname repr -> let at = if (dataReprIsValue (conDataRepr repr) || isConAsJust repr) then [] else [text "kk_reuse_null"] - in return (decls,conCreateName (getName tname) <.> arguments (at ++ ppCtxPath repr (null argDocs) ++ argDocs)) + in return (decls,conCreateName (getName tname) <.> arguments (at ++ ppCtxPath repr tname (null argDocs) ++ argDocs)) -- call to known function Var tname _ | getName tname == nameAllocAt -> failure ("Backend.C.genApp.Var.allocat: " ++ show (f,args)) @@ -1978,24 +1978,34 @@ genAppNormal f args _ -> failure $ ("Backend.C.genAppNormal: expecting function type: " ++ show (pretty (typeOf f))) return (fdecls ++ decls, text "kk_function_call" <.> arguments [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) -ppCtxPath :: ConRepr -> Bool -> [Doc] -ppCtxPath repr True = [] -ppCtxPath repr noArgs +ppCtxPath :: ConRepr -> TName -> Bool -> [Doc] +ppCtxPath repr cname True = [] +ppCtxPath repr cname noArgs = case conReprCtxPath repr of - Just cpath -> [pretty cpath] - _ -> [] + Just (CtxNone) + -> [text "0"] + Just (CtxField fname) + -> [text "kk_field_index_of" <.> tupled [ + text "struct" <+> ppName (getName cname), ppName (unqualify (getName fname)) ]] + _ -> [] -- Assign fields to a constructor. Used in: genAppNormal on conAssignFields -genAssignFields :: Doc -> TName -> TName -> [Name] -> [Expr] -> Asm ([Doc], Doc, [Doc], Doc) -genAssignFields tmp conName reuseName fieldNames fieldValues +genAssignFields :: Doc -> TName -> ConRepr -> TName -> [Name] -> [Expr] -> Asm ([Doc], Doc, [Doc], Doc) +genAssignFields tmp conName conRepr reuseName fieldNames fieldValues = do (decls,fieldDocs) <- genExprs fieldValues let conTp = text "struct" <+> ppName (getName conName) <.> text "*" tmpDecl = conTp <+> tmp <+> text "=" <+> parens conTp <.> ppName (getName reuseName) <.> semi assigns = [tmp <.> text "->" <.> ppName fname <+> text "=" <+> fval <.> semi - | (fname,fval) <- zip fieldNames fieldDocs] + | (fname,fval) <- zip fieldNames fieldDocs] + ctxpath = case conReprCtxPath conRepr of + Just (CtxField fname) + -> [text "kk_set_cpath" <.> tupled [ + text "struct" <+> ppName (getName conName), tmp, ppName (unqualify (getName fname))] + <.> semi] + _ -> [] result = conBaseCastName (getName conName) <.> arguments [tmp] - return (decls, tmpDecl, assigns, result) + return (decls, tmpDecl, ctxpath ++ assigns, result) genFieldAddress :: TName -> Name -> Name -> Doc diff --git a/src/Backend/C/ParcReuseSpec.hs b/src/Backend/C/ParcReuseSpec.hs index d816e18a9..372e77d7f 100644 --- a/src/Backend/C/ParcReuseSpec.hs +++ b/src/Backend/C/ParcReuseSpec.hs @@ -131,7 +131,7 @@ ruSpecialize reuseName info conApp specialize = oldTagBenefit + length (filter isMatch matches) >= 1 + ((1 + length args) `div` 4) case (mci, specialize) of (Just ci, True) - -> Just <$> ruSpecCon reuseName cname ci needsTag (conTag repr) (typeOf conApp) (App con) matches + -> Just <$> ruSpecCon reuseName cname repr ci needsTag (conTag repr) (typeOf conApp) (App con) matches _ -> return Nothing Nothing -> return Nothing _ -> return Nothing @@ -143,13 +143,13 @@ ruSpecialize reuseName info conApp -- | Move dups before the allocation and emit: -- if(reuseName != NULL) { set tag and fields } -- else { allocate constructor without reuse } -ruSpecCon :: TName -> TName -> ConInfo -> Bool -> Int -> Type -> ([Expr] -> Expr) -> [Match] -> Reuse Expr -ruSpecCon reuseName conName conInfo needsTag tag resultType makeConApp matches +ruSpecCon :: TName -> TName -> ConRepr -> ConInfo -> Bool -> Int -> Type -> ([Expr] -> Expr) -> [Match] -> Reuse Expr +ruSpecCon reuseName conName conRepr conInfo needsTag tag resultType makeConApp matches = do (defss, assigns) <- unzip <$> mapM ruToAssign matches let fields = map fst (conInfoParams conInfo) nonMatching = [(name,expr) | (name,(expr,isMatch)) <- zip fields assigns, not isMatch] - reuseExpr = if needsTag then genConTagFieldsAssign resultType conName reuseName tag nonMatching - else genConFieldsAssign resultType conName reuseName nonMatching + reuseExpr = if needsTag then genConTagFieldsAssign resultType conName conRepr reuseName tag nonMatching + else genConFieldsAssign resultType conName conRepr reuseName nonMatching specExpr = makeIfExpr (genReuseIsValid reuseName) reuseExpr (makeConApp (map fst assigns)) return (makeLet (concat defss) specExpr) @@ -199,20 +199,20 @@ genReuseIsValid reuseName -- genConFieldsAssign tp conName reuseName [(field1,expr1)...(fieldN,exprN)] -- generates: c = (conName*)reuseName; c->field1 := expr1; ... ; c->fieldN := exprN; (tp*)(c) -genConTagFieldsAssign :: Type -> TName -> TName -> Int -> [(Name,Expr)] -> Expr -genConTagFieldsAssign resultType conName reuseName tag fieldExprs +genConTagFieldsAssign :: Type -> TName -> ConRepr -> TName -> Int -> [(Name,Expr)] -> Expr +genConTagFieldsAssign resultType conName conRepr reuseName tag fieldExprs = App (Var (TName nameConTagFieldsAssign typeConFieldsAssign) (InfoArity 0 (length fieldExprs + 1))) - ([Var reuseName (InfoConField conName nameNil), Var (TName (newName (show tag)) typeUnit) InfoNone] ++ map snd fieldExprs) + ([Var reuseName (InfoConField conName conRepr nameNil), Var (TName (newName (show tag)) typeUnit) InfoNone] ++ map snd fieldExprs) where fieldTypes = [(name,typeOf expr) | (name,expr) <- fieldExprs] typeConFieldsAssign = TFun ([(nameNil,typeOf reuseName), (nameNil, typeUnit)] ++ fieldTypes) typeTotal resultType -- genConTagFieldsAssign tp conName reuseName [(field1,expr1)...(fieldN,exprN)] -- generates: c = (conName*)reuseName; c->field1 := expr1; ... ; c->fieldN := exprN; (tp*)(c) -genConFieldsAssign :: Type -> TName -> TName -> [(Name,Expr)] -> Expr -genConFieldsAssign resultType conName reuseName fieldExprs +genConFieldsAssign :: Type -> TName -> ConRepr -> TName -> [(Name,Expr)] -> Expr +genConFieldsAssign resultType conName conRepr reuseName fieldExprs = App (Var (TName nameConFieldsAssign typeConFieldsAssign) (InfoArity 0 (length fieldExprs + 1))) - (Var reuseName (InfoConField conName nameNil) : map snd fieldExprs) + (Var reuseName (InfoConField conName conRepr nameNil) : map snd fieldExprs) where fieldTypes = [(name,typeOf expr) | (name,expr) <- fieldExprs] typeConFieldsAssign = TFun ((nameNil,typeOf reuseName) : fieldTypes) typeTotal resultType diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index 515fb0830..a3eeb9121 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -72,10 +72,10 @@ cctxExpr :: Expr -> CCtx Ctx cctxExpr expr = case expr of -- constructor - App con@(Con name repr) args | not (null args) + App con@(Con name repr) args | conReprHasCtxPath repr && not (null args) -> cctxCon name repr [] args - App (TypeApp (con@(Con name repr)) targs) args | not (null args) + App (TypeApp (con@(Con name repr)) targs) args | conReprHasCtxPath repr && not (null args) -> cctxCon name repr targs args -- App (App (TypeApp (Var open _) [effFrom,effTo,tpFrom,tpTo]) [f]) []) | getName open == nameEffectOpen @@ -106,10 +106,11 @@ cctxConRecurse conName conRepr targs args (pre,ctx,post) <- cctxFind [] [] args mapM_ cctxCheckNoHole (pre ++ post) (ds,vars) <- unzip <$> mapM makeUniqueDef pre - (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (vars ++ [top ctx] ++ post)) fname <- getFieldName conName (length pre + 1) - (d2,var2) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) - return (ctx{ defs = ds ++ defs ctx ++ [d1,d2], top = var2 }) + let ctxrepr = conRepr{ conCtxPath = CtxField fname } + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName ctxrepr) targs) (vars ++ [top ctx] ++ post)) + -- (d2,var2) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) + return (ctx{ defs = ds ++ defs ctx ++ [d1], top = var1 }) cctxConFinal :: TName -> ConRepr -> [Type] -> [Expr] -> Expr -> [Expr] -> CCtx Ctx cctxConFinal conName conRepr targs pre hole post @@ -117,11 +118,12 @@ cctxConFinal conName conRepr targs pre hole post mapM_ cctxCheckNoHole (pre ++ post) fname <- getFieldName conName (length pre + 1) let holetp = typeOf hole + ctxrepr = conRepr{ conCtxPath = CtxField fname } ensureValidHoleType holetp - (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName conRepr) targs) (pre ++ [hole] ++ post)) - (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName fname holetp) - (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) -- should be last as it consumes var1 - return (Ctx [d1,d2,d3] var3 (Hole addr holetp)) + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName ctxrepr) targs) (pre ++ [hole] ++ post)) + (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName (getName fname) holetp) + -- (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) -- should be last as it consumes var1 + return (Ctx [d1,d2] var1 (Hole addr holetp)) cctxCheckNoHole :: Expr -> CCtx () cctxCheckNoHole expr @@ -278,7 +280,7 @@ mtrace msg trace ("Core.AnalysisCCtx: " ++ msg) $ return () -getFieldName :: TName -> Int -> CCtx Name +getFieldName :: TName -> Int -> CCtx TName getFieldName cname fieldIdx = do info <- lookupFieldName cname fieldIdx case info of @@ -305,7 +307,7 @@ dataTypeNameOf tp = case expandSyn tp of t -> Left t -lookupFieldName :: TName -> Int -> CCtx (Either String Name) +lookupFieldName :: TName -> Int -> CCtx (Either String TName) lookupFieldName cname field = do env <- getEnv case newtypesLookupAny (getDataTypeName cname) (newtypes env) of @@ -315,7 +317,7 @@ lookupFieldName cname field then return (Left ("contexts cannot go through a value type (" ++ show (getName cname) ++ ")")) else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of [con] -> case drop (field - 1) (conInfoParams con) of - ((fname,ftp):_) -> return $ Right fname {- Con cname (getConRepr dataInfo con), fname) -} + ((fname,ftp):_) -> return $ Right (TName fname ftp) {- Con cname (getConRepr dataInfo con), fname) -} _ -> failure $ "Core.CTail.getFieldName: field index is off: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (conInfoParams con) _ -> failure $ "Core.CTail.getFieldName: cannot find constructor: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (dataInfoConstrs dataInfo) _ -> failure $ "Core.CTail.getFieldName: no such constructor: " ++ show cname ++ ", field " ++ show field diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 5aac29866..5bc14bd2f 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -66,7 +66,7 @@ module Core.Core ( -- Data structures , isConSingleton , isConNormal , isConIso, isConAsJust - , conReprHasCtxPath, conReprCtxPath + , conReprHasCtxPath, conReprCtxPath, CtxPath(..) , isDataStruct, isDataAsMaybe, isDataStructAsMaybe , conReprAllocSize, conReprAllocSizeScan, conReprScanCount , getDataRepr, getDataReprEx, dataInfoIsValue @@ -181,7 +181,7 @@ makeList tp exprs nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList valueReprZero 0) nil = TypeApp nilCon [tp] consTp = TForall [a] [] (typeFun [(nameNil,TVar a),(nameNil,TApp typeList [TVar a])] typeTotal (TApp typeList [TVar a])) - consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull 2 0) -- NOTE: depends on Cons being second in the definition in std/core :-( + consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull CtxNone 2) -- NOTE: depends on Cons being second in the definition in std/core :-( cons expr xs = App (TypeApp consCon [tp]) [expr,xs] a = TypeVar (0) kindStar Bound @@ -369,14 +369,17 @@ data DataRepr = -- value types data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- part of enumeration (none has fields) | ConIso{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- one constructor with one field | ConSingleton{conTypeName::Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor without fields (and not part of an enum) - | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) + | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor as value type - | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conCtxPath :: Int, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) - | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int } -- constructor of open data type - | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: Int, conTag :: Int } -- a regular constructor + | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conCtxPath :: CtxPath, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) + | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath } -- constructor of open data type + | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath, conTag :: Int } -- a regular constructor deriving (Eq,Ord,Show) +data CtxPath = CtxNone | CtxField TName + deriving(Eq,Ord,Show) + isConSingleton (ConSingleton{}) = True isConSingleton _ = False @@ -404,8 +407,8 @@ conReprHasCtxPath repr Nothing -> False _ -> True -conReprCtxPath :: ConRepr -> Maybe Int -conReprCtxPath repr | conReprIsValue repr = Nothing +conReprCtxPath :: ConRepr -> Maybe CtxPath +conReprCtxPath repr | conReprIsValue repr = Nothing conReprCtxPath repr = case repr of ConSingle{ conCtxPath = cpath } -> Just cpath @@ -465,7 +468,7 @@ getDataReprEx getIsValue info isValue = getIsValue info && not (dataInfoIsRec info) (dataRepr,conReprFuns) = if (dataInfoIsOpen(info)) - then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo) 0) conInfos) + then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo) CtxNone) conInfos) -- TODO: only for C#? check this during kind inference? -- else if (hasExistentials) -- then (DataNormal, map (\con -> ConNormal typeName) conInfos) @@ -484,7 +487,7 @@ getDataReprEx getIsValue info in (dataRepr ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr valRepr else if length singletons == 1 then ConSingleton typeName dataRepr valRepr - else ConSingle typeName dataRepr valRepr 0]) + else ConSingle typeName dataRepr valRepr CtxNone]) else if (isValue && not (dataInfoIsRec info)) then ( let dataRepr = if (length conInfos == 2 && length singletons == 1 && case (filter (\cinfo -> length (conInfoParams cinfo) == 1) conInfos) of -- at most 1 field @@ -513,7 +516,7 @@ getDataReprEx getIsValue info else (DataAsList ,map (\ci tag -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsList (conInfoValueRepr ci) tag - else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) tag 0) conInfos) + else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) CtxNone tag) conInfos) ) else let dataRepr = if (length singletons == length conInfos -1 || null conInfos) @@ -521,7 +524,7 @@ getDataReprEx getIsValue info in (dataRepr ,map (\ci -> if null (conInfoParams ci) then ConSingleton typeName dataRepr (conInfoValueRepr ci) - else ConNormal typeName dataRepr (conInfoValueRepr ci) 0) conInfos + else ConNormal typeName dataRepr (conInfoValueRepr ci) CtxNone) conInfos ) ) in (dataRepr, [conReprFun tag | (conReprFun,tag) <- zip conReprFuns [1..]]) @@ -708,7 +711,7 @@ data VarInfo | InfoArity Int Int -- #Type parameters, #parameters | InfoExternal [(Target,String)] -- inline body | InfoReuse Pattern - | InfoConField TName Name -- constructor name, field name + | InfoConField TName ConRepr Name -- constructor name, repr, field name (inserted by reuse specialization) data TName = TName { getName :: Name @@ -739,7 +742,7 @@ instance Show VarInfo where -> "" InfoReuse pat -> "reuse:" - InfoConField conName fieldName + InfoConField conName conRepr fieldName -> "field:" ++ show conName ++ "." ++ show fieldName InfoArity m n -> "arity:" ++ show (m,n) From c70abef49ef28eede49969871a7b7ffcabe6328f Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 30 Jun 2023 10:34:30 -0700 Subject: [PATCH 225/233] use set_cpath for trmc as well --- kklib/include/kklib.h | 2 +- lib/std/core/types.kk | 2 +- src/Core/CTail.hs | 59 +++++++++++++++++++++++++------------------ src/Core/CheckFBIP.hs | 1 + 4 files changed, 37 insertions(+), 27 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 28a59ad3a..d740b38ce 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 112 // modify on changes to trigger recompilation +#define KKLIB_BUILD 113 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 10772f6cc..58205f1c5 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -20,7 +20,7 @@ pub infixr 55 (++.) pub infixr 30 (&&) pub infixr 20 (||) -// build: 112 +// build: 113 // ---------------------------------------------------------------------------- // Core types diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 1c59109aa..2f5afdc8c 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -275,7 +275,7 @@ ctailExpr top expr return (makeCCtxApply isMulti alwaysAffine slot body) handleConApp dname cname fcon fargs - = do let mkCons args = bindArgs args $ (\xs -> return ([],App fcon xs)) + = do let mkCons cpath args = bindArgs args $ \xs -> return ([],mkConApp cpath fcon xs) isMulti <- getIsMulti useContextPath <- getUseContextPath alwaysAffine <- getIsAlwaysAffine @@ -292,6 +292,16 @@ ctailExpr top expr Just slot -> do ctailVar <- getCTailFun -- do a tail call with the current slot return (mkCall ctailVar (Var slot InfoNone)) +mkConApp :: CtxPath -> Expr -> [Expr] -> Expr +mkConApp cpath fcon xs + = case cpath of + CtxField fname -> case fcon of + Con conName conRepr -> App (Con conName conRepr{conCtxPath=cpath}) xs + TypeApp (Con conName conRepr) targs -> App (TypeApp (Con conName conRepr{conCtxPath=cpath}) targs) xs + _ -> failure ("Core.CTail.mkConApp: invalid constructor: " ++ show fcon) + _ -> App fcon xs + + bindArgs :: [Expr] -> ([Expr] -> CTail ([DefGroup],Expr)) -> CTail ([DefGroup],Expr) bindArgs args use = do (defss,args') <- unzip <$> mapM bindArg args @@ -320,7 +330,7 @@ ctailGuard (Guard test expr) -- expects patAdded in depth-order -- See if the tailcall is inside a (nested) constructor application -------------------------------------------------------------------------- -ctailTryArg :: Bool -> TName -> TName -> Maybe TName -> ([Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) +ctailTryArg :: Bool -> TName -> TName -> Maybe TName -> (CtxPath -> [Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) ctailTryArg useCtxPath dname cname mbC mkApp field [] = return Nothing ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) = case rarg of @@ -342,25 +352,32 @@ ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) -> do x <- uniqueTName (typeOf rarg) ctailTryArg useCtxPath dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) - _ -> if (isTotal rarg) then ctailTryArg useCtxPath dname cname mbC (\args -> mkApp (args ++ [rarg])) (field-1) rargs + _ -> if (isTotal rarg) then ctailTryArg useCtxPath dname cname mbC (\cpath args -> mkApp cpath (args ++ [rarg])) (field-1) rargs else return Nothing where -- create a tail call mkAppNew - = \args -> do (defs,cexpr) <- mkApp (reverse rargs ++ args) + = \args -> do cpath <- getCtxPath useCtxPath cname field + mkApp cpath (reverse rargs ++ args) + {- if not useCtxPath then return (defs,cexpr) else do setfld <- setContextPathExpr cname field x <- uniqueTName (typeOf cexpr) y <- uniqueTName (typeOf cexpr) let cexprdef = DefNonRec (makeTDef y cexpr) let setdef = DefNonRec (makeTDef x (setfld y)) - return (defs ++ [cexprdef,setdef], (Var x InfoNone)) + return (defs ++ [cexprdef,setdef], (Var x InfoNone)) -} -- create the constructor context (ending in a hole) - mkAppNested :: TName -> Expr -> ([Expr] -> CTail ([DefGroup],Expr)) + mkAppNested :: TName -> Expr -> (CtxPath -> [Expr] -> CTail ([DefGroup],Expr)) mkAppNested x fcon - = \args -> do (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp (xs ++ [Var x InfoNone]) + = \fcpath args -> do cpath <- getCtxPath useCtxPath cname field + (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp cpath (xs ++ [Var x InfoNone]) + let condef = DefNonRec (makeTDef x (mkConApp fcpath fcon args)) + return ([condef] ++ defs, expr) + {- + --(defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp cpath (xs ++ [Var x InfoNone]) if not useCtxPath then do let condef = DefNonRec (makeTDef x (App fcon args)) return ([condef] ++ defs, expr) @@ -369,15 +386,16 @@ ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) let condef = DefNonRec (makeTDef y (App fcon args)) let setdef = DefNonRec (makeTDef x (setfld y)) return ([condef,setdef] ++ defs, expr) + -} - -setContextPathExpr cname field - = do fieldInfo <- getFieldName cname field +getCtxPath :: Bool -> TName -> Int -> CTail CtxPath +getCtxPath False cname fieldIdx = return CtxNone +getCtxPath useContextPath cname fieldIdx + = do fieldInfo <- getFieldName cname fieldIdx case fieldInfo of Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 - Right (_,fieldName) -> - return (\parent -> makeCCtxSetContextPath (Var parent InfoNone) cname fieldName) - + Right (_,fieldName) -> return (CtxField fieldName) + -------------------------------------------------------------------------- @@ -410,7 +428,7 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs (defs,cons) <- mkConsApp [hole] consName <- uniqueTName (typeOf cons) alwaysAffine <- getIsAlwaysAffine - let comp = makeCCtxExtend slot consName (maybe consName id mbC) cname fieldName resTp alwaysAffine + let comp = makeCCtxExtend slot consName (maybe consName id mbC) cname (getName fieldName) resTp alwaysAffine ctailCall = mkTailApp ctailVar comp return $ (defs ++ [DefNonRec (makeTDef consName cons)] ,ctailCall) @@ -491,15 +509,6 @@ makeCCtxApply False alwaysAffine slot expr -- slot is a `ctail` a = TypeVar (-1) kindStar Bound --- Set the index of the field in a constructor to follow the path to the hole at runtime. -makeCCtxSetContextPath :: Expr -> TName -> Name -> Expr -makeCCtxSetContextPath obj conName fieldName - = App (Var (TName nameCCtxSetCtxPath funType) (InfoExternal [(Default,".cctx-setcp(#1,#2,#3)")])) - [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] - where - tp = typeOf obj - funType = (TFun [(nameNil,tp),(nameNil,typeString),(nameNil,typeString)] typeTotal tp) - -------------------------------------------------------------------------- -- Utilities for readability @@ -598,7 +607,7 @@ getIsAlwaysAffine :: CTail Bool getIsAlwaysAffine = alwaysAffine <$> getEnv -getFieldName :: TName -> Int -> CTail (Either String (Expr,Name)) +getFieldName :: TName -> Int -> CTail (Either String (Expr,TName)) getFieldName cname field = do env <- getEnv case newtypesLookupAny (getDataTypeName cname) (newtypes env) of @@ -608,7 +617,7 @@ getFieldName cname field then return (Left ("cannot optimize modulo-cons tail-call through a value type (" ++ show (getName cname) ++ ")")) else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of [con] -> case drop (field - 1) (conInfoParams con) of - ((fname,ftp):_) -> return $ Right (Con cname (getConRepr dataInfo con), fname) + ((fname,ftp):_) -> return $ Right (Con cname (getConRepr dataInfo con), TName fname ftp) _ -> failure $ "Core.CTail.getFieldName: field index is off: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (conInfoParams con) _ -> failure $ "Core.CTail.getFieldName: cannot find constructor: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (dataInfoConstrs dataInfo) _ -> failure $ "Core.CTail.getFieldName: no such constructor: " ++ show cname ++ ", field " ++ show field diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index baa9519f2..586a979f3 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -234,6 +234,7 @@ chkArg (Borrow, expr) (App (TypeApp (Var openName _) _) [fn]) | getName openName == nameEffectOpen -> chkArg (Borrow, fn) -- disregard .open calls (Var tname info) -> markBorrowed tname info + (Lit _) -> pure () _ -> do chkExpr expr requireCapability mayDealloc $ \ppenv -> Just $ vcat [text "passing owned expressions as borrowed causes deallocation:", source ppenv (prettyExpr ppenv expr)] From 6090d9f74c8cdf70c1f5cb68f636a8426b6bcd5d Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 30 Jun 2023 11:37:35 -0700 Subject: [PATCH 226/233] add ctz, clz, and popcount --- lib/std/core/core-integer-inline.js | 53 +++++++++++++++++++++++++++++ lib/std/num/int32.kk | 27 +++++++++++++++ lib/std/num/int64.kk | 28 +++++++++++++++ 3 files changed, 108 insertions(+) diff --git a/lib/std/core/core-integer-inline.js b/lib/std/core/core-integer-inline.js index 8168b021d..20739b5ff 100644 --- a/lib/std/core/core-integer-inline.js +++ b/lib/std/core/core-integer-inline.js @@ -74,6 +74,30 @@ export function _int32_rotr(x,y) { return ((x >>> shift) | (x << (32 - shift))); } +export function _int32_ctz(x) { + var i = (x|0); + i |= (i << 16); + i |= (i << 8); + i |= (i << 4); + i |= (i << 2); + i |= (i << 1); + return ((32 - Math.clz32(~i))|0); +} + +export function _int32_clz(x) { + return Math.clz32(x); +} + +export function _int32_bits_count(x) { + var i = (x|0); + i = i - ((i >> 1) & 0x55555555); + i = (i & 0x33333333) + ((i >> 2) & 0x33333333); + i = (i + (i >> 4)) & 0x0F0F0F0F; + i = i + (i >> 8); + i = i + (i >> 16); + return (i & 0x3F); +} + const _int65 = 0x10000000000000000n; export function _int64_shr(x,y) { @@ -110,6 +134,35 @@ export function _int64_rotr(x,y) { return _int64_rotl(x, 64n - y); } +export function _int64_ctz(x) { + const lo = Number( x & 0xFFFFFFFFn ); + if (lo === 0) { + const hi = Number( _int64_shr(x,32n) ); + return BigInt(32 + _int32_ctz(hi)); + } + else { + return BigInt(_int32_ctz(lo)); + } +} + +export function _int64_clz(x) { + const hi = Number( _int64_shr(x,32n) ); + if (hi === 0) { + const lo = Number( x & 0xFFFFFFFFn ); + return BigInt(32 + _int32_clz(lo)); + } + else { + return BigInt(_int32_clz(hi)); + } +} + +export function _int64_bits_count(x) { + const hi = Number( _int64_shr(x,32n) ); + const lo = Number( x & 0xFFFFFFFFn ); + return BigInt(_int32_bits_count(hi) + _int32_bits_count(lo)); +} + + export function _int64_from_uint32(x) { return (x >= 0 ? BigInt(x) : 0x100000000n + BigInt(x)) } diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 16eebcf07..221aed125 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -237,6 +237,33 @@ inline fip extern rotr32( i : int32, n : int32 ) : int32 pub fip fun rotr( i : int32, shift : int ) : int32 rotr32( i, shift.int32 ) +// Count trailing zeros. Returns 32 if `i` is zero. +inline fip extern ctz32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_ctz32(#1)" + js "$std_core._int32_ctz" + +// Count leading zeros. Returns 32 if `i` is zero. +inline fip extern clz32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_clz32(#1)" + js "$std_core._int32_clz" + +// Count number of 1-bits. +inline fip extern popcount32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_count(#1)" + js "$std_core._int32_bits_count" + +// Count trailing zeros. Returns 32 if `i` is zero. +pub fip fun ctz( i : int32 ) : int + ctz32(i).int + +// Count leading zeros. Returns 32 if `i` is zero. +pub fip fun clz( i : int32 ) : int + clz32(i).int + +// Count number of 1-bits. +pub fip fun popcount( i : int32 ) : int + popcount32(i).int + // Return the minimum of two integers pub fip fun min( i : int32, j : int32 ) : int32 diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 1cd1b6244..1f2faa371 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -255,6 +255,34 @@ inline fip extern rotr64( i : int64, n : int64 ) : int64 pub fip fun rotr( i : int64, shift : int) : int64 rotr64(i,shift.int64) +// Count trailing zeros. Returns 64 if `i` is zero. +inline fip extern ctz64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_ctz64(#1)" + js "$std_core._int64_ctz" + +// Count leading zeros. Returns 64 if `i` is zero. +inline fip extern clz64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_clz64(#1)" + js "$std_core._int64_clz" + +// Count number of 1-bits. +inline fip extern popcount64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_count(#1)" + js "$std_core._int64_bits_count" + +// Count trailing zeros. Returns 64 if `i` is zero. +pub fip fun ctz( i : int64 ) : int + ctz64(i).int + +// Count leading zeros. Returns 64 if `i` is zero. +pub fip fun clz( i : int64 ) : int + clz64(i).int + +// Count number of 1-bits. +pub fip fun popcount( i : int64 ) : int + popcount64(i).int + + // Return the minimum of two integers pub fip fun min( i : int64, j : int64 ) : int64 From ac9b4367cf736c92c778249163a1b7d9927941f1 Mon Sep 17 00:00:00 2001 From: daanx Date: Fri, 30 Jun 2023 11:56:39 -0700 Subject: [PATCH 227/233] small edits --- lib/std/num/int32.kk | 10 +++++----- lib/std/num/int64.kk | 10 +++++----- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 221aed125..9a0c9f07d 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -1,5 +1,5 @@ /*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. + Copyright 2012-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -237,12 +237,12 @@ inline fip extern rotr32( i : int32, n : int32 ) : int32 pub fip fun rotr( i : int32, shift : int ) : int32 rotr32( i, shift.int32 ) -// Count trailing zeros. Returns 32 if `i` is zero. +// Count trailing zero bits. Returns 32 if `i` is zero. inline fip extern ctz32( i : int32 ) : int32 c inline "(int32_t)kk_bits_ctz32(#1)" js "$std_core._int32_ctz" -// Count leading zeros. Returns 32 if `i` is zero. +// Count leading zero bits. Returns 32 if `i` is zero. inline fip extern clz32( i : int32 ) : int32 c inline "(int32_t)kk_bits_clz32(#1)" js "$std_core._int32_clz" @@ -252,11 +252,11 @@ inline fip extern popcount32( i : int32 ) : int32 c inline "(int32_t)kk_bits_count(#1)" js "$std_core._int32_bits_count" -// Count trailing zeros. Returns 32 if `i` is zero. +// Count trailing zero bits. Returns 32 if `i` is zero. pub fip fun ctz( i : int32 ) : int ctz32(i).int -// Count leading zeros. Returns 32 if `i` is zero. +// Count leading zero bits. Returns 32 if `i` is zero. pub fip fun clz( i : int32 ) : int clz32(i).int diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 1f2faa371..7fbc8ee82 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -1,5 +1,5 @@ /*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. + Copyright 2012-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -255,12 +255,12 @@ inline fip extern rotr64( i : int64, n : int64 ) : int64 pub fip fun rotr( i : int64, shift : int) : int64 rotr64(i,shift.int64) -// Count trailing zeros. Returns 64 if `i` is zero. +// Count trailing zero bits. Returns 64 if `i` is zero. inline fip extern ctz64( i : int64 ) : int64 c inline "(int64_t)kk_bits_ctz64(#1)" js "$std_core._int64_ctz" -// Count leading zeros. Returns 64 if `i` is zero. +// Count leading zero bits. Returns 64 if `i` is zero. inline fip extern clz64( i : int64 ) : int64 c inline "(int64_t)kk_bits_clz64(#1)" js "$std_core._int64_clz" @@ -270,11 +270,11 @@ inline fip extern popcount64( i : int64 ) : int64 c inline "(int64_t)kk_bits_count(#1)" js "$std_core._int64_bits_count" -// Count trailing zeros. Returns 64 if `i` is zero. +// Count trailing zero bits. Returns 64 if `i` is zero. pub fip fun ctz( i : int64 ) : int ctz64(i).int -// Count leading zeros. Returns 64 if `i` is zero. +// Count leading zero bits. Returns 64 if `i` is zero. pub fip fun clz( i : int64 ) : int clz64(i).int From a472dd2450bcc9515b518cd4ee97d24e8b698eb9 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 1 Jul 2023 12:14:19 -0700 Subject: [PATCH 228/233] improve ctz,clz, add ffs --- kklib/include/kklib/bits.h | 260 +++++++++++++++++++--------- kklib/src/bits.c | 28 +-- kklib/test/main.c | 12 +- lib/std/core/core-integer-inline.js | 23 ++- lib/std/num/int32.kk | 4 +- lib/std/num/int64.kk | 4 +- 6 files changed, 209 insertions(+), 122 deletions(-) diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index d546ea255..f3f19bd6b 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -3,7 +3,7 @@ #define KK_BITS_H /*--------------------------------------------------------------------------- - Copyright 2020-2021, Microsoft Research, Daan Leijen. + Copyright 2020-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -110,93 +110,181 @@ static inline kk_uintx_t kk_bits_rotr(kk_uintx_t x, kk_uintx_t shift) { /* ----------------------------------------------------------- - `clz` count leading zero bits - `ctz` count trailing zero bits + `clz` count leading zero bits (32/64 for zero) + `ctz` count trailing zero bits (32/64 for zero) + `ffs` find first set: bit-index + 1, or 0 for zero + `fls` find last set: bit-index + 1, or 0 for zero ----------------------------------------------------------- */ #if defined(__GNUC__) -static inline uint8_t kk_bits_clz32(uint32_t x) { +static inline int kk_bits_clz32(uint32_t x) { return (x==0 ? 32 : __builtin32(clz)(x)); } -static inline uint8_t kk_bits_ctz32(uint32_t x) { +static inline int kk_bits_ctz32(uint32_t x) { return (x==0 ? 32 : __builtin32(ctz)(x)); } +static inline int kk_bits_ffs32(uint32_t x) { + return __builtin32(ffs)(x); +} #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { return (x==0 ? 64 : __builtin64(clz)(x)); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { +static inline int kk_bits_ctz64(uint64_t x) { return (x==0 ? 64 : __builtin64(ctz)(x)); } +static inline int kk_bits_ffs64(uint64_t x) { + return __builtin64(ffs)(x); +} #endif -#elif defined(_MSC_VER) && !defined(__clang_msvc__) && (defined(_M_ARM64) || defined(_M_ARM) || defined(_M_X64) || defined(_M_IX86)) +#elif defined(_MSC_VER) && (defined(_M_ARM64) || defined(_M_ARM) || defined(_M_X64) || defined(_M_IX86)) #include - -#if defined(_M_X64) || defined(_M_IX86) -extern bool kk_has_lzcnt; // initialized in runtime.c -extern bool kk_has_tzcnt; -#endif - -static inline uint8_t kk_bits_clz32(uint32_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if kk_likely(kk_has_lzcnt) return (uint8_t)__lzcnt(x); - #endif +static inline int kk_bits_clz32(uint32_t x) { + unsigned long idx; + return (_BitScanReverse(&idx, x) ? 31 - (int)idx : 32); +} +static inline int kk_bits_ctz32(uint32_t x) { unsigned long idx; - return (_BitScanReverse(&idx, x) ? 31 - (uint8_t)idx : 32); + return (_BitScanForward(&idx, x) ? (int)idx : 32); } -static inline uint8_t kk_bits_ctz32(uint32_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if kk_likely(kk_has_tzcnt) return (uint8_t)_tzcnt_u32(x); - #endif +static inline int kk_bits_ffs32(uint32_t x) { unsigned long idx; - return (_BitScanForward(&idx, x) ? (uint8_t)idx : 32); + return (_BitScanForward(&idx, x) ? 1 + (int)idx : 0); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if kk_likely(kk_has_lzcnt) return (uint8_t)__lzcnt64(x); - #endif +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { + unsigned long idx; + return (_BitScanReverse64(&idx, x) ? 63 - (int)idx : 64); +} +static inline int kk_bits_ctz64(uint64_t x) { unsigned long idx; - return (_BitScanReverse64(&idx, x) ? 63 - (uint8_t)idx : 64); + return (_BitScanForward64(&idx, x) ? (int)idx : 64); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if kk_likely(kk_has_tzcnt) return (uint8_t)_tzcnt_u64(x); - #endif +static inline int kk_bits_ffs64(uint64_t x) { unsigned long idx; - return (_BitScanForward64(&idx, x) ? (uint8_t)idx : 64); + return (_BitScanForward64(&idx, x) ? 1 + (int)idx : 0); } #endif #else #define KK_BITS_USE_GENERIC_CTZ_CLZ 1 -kk_decl_export uint8_t kk_bits_ctz32(uint32_t x); -kk_decl_export uint8_t kk_bits_clz32(uint32_t x); +kk_decl_export int kk_bits_ctz32(uint32_t x); +kk_decl_export int kk_bits_clz32(uint32_t x); +static inline int kk_bits_ffs32(uint32_t x) { + return (x == 0 ? 0 : 1 + kk_bits_ctz32(x)); +} #endif -#ifndef HAS_BITS_CLZ64 -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { - uint8_t cnt = kk_bits_clz32((uint32_t)(x >> 32)); +#ifndef KK_HAS_BITS_CLZ64 +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { + int cnt = kk_bits_clz32((uint32_t)(x >> 32)); if (cnt < 32) return cnt; return (32 + kk_bits_clz32((uint32_t)x)); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { - uint8_t cnt = kk_bits_ctz32((uint32_t)x); +static inline int kk_bits_ctz64(uint64_t x) { + int cnt = kk_bits_ctz32((uint32_t)x); if (cnt < 32) return cnt; return (32 + kk_bits_ctz32((uint32_t)(x >> 32))); } +static inline int kk_bits_ffs64(uint64_t x) { + if (x == 0) return 0; + int idx = kk_bits_ffs32((uint32_t)x); + if (idx > 0) return idx; + return (32 + kk_bits_ffs32((uint32_t)(x >> 32))); +} #endif -static inline uint8_t kk_bits_clz(kk_uintx_t x) { +static inline int kk_bits_fls32(uint32_t x) { + return (32 - kk_bits_clz32(x)); +} +static inline int kk_bits_fls64(uint64_t x) { + return (64 - kk_bits_clz64(x)); +} + +static inline int kk_bits_clz(kk_uintx_t x) { return kk_bitsx(clz)(x); } -static inline uint8_t kk_bits_ctz(kk_uintx_t x) { +static inline int kk_bits_ctz(kk_uintx_t x) { return kk_bitsx(ctz)(x); } +static inline int kk_bits_ffs(kk_uintx_t x) { + return kk_bitsx(ffs)(x); +} +static inline int kk_bits_fls(kk_uintx_t x) { + return kk_bitsx(fls)(x); +} + +/* ----------------------------------------------------------- + count leading redundant sign bits (i.e. the number of bits + following the most significant bit that are identical to it). + + clrsb31(INT32_MAX) == 0 + ... + clrsb31(1) == 30 + clrsb32(0) == 31 + clrsb32(-1) == 31 + clrsb32(-2) == 30 + ... + clrsb32(INT32_MIN) = 0 +----------------------------------------------------------- */ + +static inline int kk_bits_clrsb32(int32_t x) { + const int32_t i = kk_sar32(x, 31) ^ x; + if (i == 0) return 31; // x==0 or x==1 + else return kk_bits_clz32(i) - 1; +} + +static inline int kk_bits_clrsb64(int64_t x) { + const int64_t i = kk_sar64(x, 63) ^ x; + if (i == 0) return 63; // x==0 or x==1 + else return kk_bits_clz64(i) - 1; +} + +static inline int kk_bits_clrsb(kk_intx_t x) { + return kk_bitsx(clrsb)(x); +} + + +/* ----------------------------------------------------------- + clear least-significant bit +----------------------------------------------------------- */ + +#define _kk_bits_clear_lsb(x) ((x) & ((x)-1)) + +static inline uint32_t kk_bits_clear_lsb32(uint32_t x) { + return _kk_bits_clear_lsb(x); +} + +static inline uint64_t kk_bits_clear_lsb64(uint64_t x) { + return _kk_bits_clear_lsb(x); +} + +static inline kk_uintx_t kk_bits_clear_lsb(kk_uintx_t x) { + return kk_bitsx(clear_lsb)(x); +} + +/* ----------------------------------------------------------- + keep (only) least-significant bit +----------------------------------------------------------- */ + +#define _kk_bits_only_keep_lsb(x) ((x) & (~(x)+1)) + +static inline uint32_t kk_bits_only_keep_lsb32(uint32_t x) { + return _kk_bits_only_keep_lsb(x); +} + +static inline uint64_t kk_bits_only_keep_lsb64(uint64_t x) { + return _kk_bits_only_keep_lsb(x); +} + +static inline kk_uintx_t kk_bits_only_keep_lsb(kk_uintx_t x) { + return kk_bitsx(only_keep_lsb)(x); +} + /* ----------------------------------------------------------- Byte operations @@ -276,60 +364,60 @@ static inline uint8_t kk_bits_byte_sum(kk_uintx_t x) { /* --------------------------------------------------------------- - kk_bits_count: population count / hamming weight (count set bits) + kk_bits_popcount: population count / hamming weight (count set bits) see ------------------------------------------------------------------ */ -kk_decl_export uint32_t kk_bits_generic_count32(uint32_t x); -kk_decl_export uint64_t kk_bits_generic_count64(uint64_t x); +kk_decl_export int kk_bits_generic_popcount32(uint32_t x); +kk_decl_export int kk_bits_generic_popcount64(uint64_t x); #if defined(_MSC_VER) && (defined(_M_X64) || defined(_M_IX86)) #include extern bool kk_has_popcnt; // initialized in runtime.c -static inline uint32_t kk_bits_count32(uint32_t x) { - if (kk_has_popcnt) return __popcnt(x); - return kk_bits_generic_count32(x); +static inline int kk_bits_popcount32(uint32_t x) { + if (kk_has_popcnt) return (int)__popcnt(x); + return kk_bits_generic_popcount32(x); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - if (kk_has_popcnt) return __popcnt64(x); - return kk_bits_generic_count64(x); +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + if (kk_has_popcnt) return (int)__popcnt64(x); + return kk_bits_generic_popcount64(x); } #endif #elif defined(__GNUC__) -static inline uint32_t kk_bits_count32(uint32_t x) { +static inline int kk_bits_popcount32(uint32_t x) { return __builtin32(popcount)(x); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { return __builtin64(popcount)(x); } #endif #else -static inline uint32_t kk_bits_count32(uint32_t x) { - return kk_bits_generic_count32(x); +static inline int kk_bits_popcount32(uint32_t x) { + return kk_bits_generic_popcount32(x); } -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - return kk_bits_generic_count64(x); +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + return kk_bits_generic_popcount64(x); } #endif -#ifndef HAS_BITS_COUNT64 -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - return ((uint64_t)kk_bits_count32((uint32_t)x) + kk_bits_count32((uint32_t)(x>>32))); +#ifndef KK_HAS_BITS_POPCOUNT64 +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + return (kk_bits_popcount32((uint32_t)x) + kk_bits_popcount32((uint32_t)(x>>32))); } #endif -static inline kk_uintx_t kk_bits_count(kk_uintx_t x) { - return kk_bitsx(count)(x); +static inline int kk_bits_popcount(kk_uintx_t x) { + return kk_bitsx(popcount)(x); } @@ -470,51 +558,51 @@ static inline double kk_bits_to_double(uint64_t x) { /* --------------------------------------------------------------- - Parity: returns `kk_bits_count(x) % 2` + Parity: returns `kk_bits_popcount(x) % 2` see ------------------------------------------------------------------ */ #if defined(_MSC_VER) && (defined(_M_X64) || defined(_M_IX86)) -static inline bool kk_bits_count_is_even32(uint32_t x) { - return ((kk_bits_count32(x) & 1) == 0); +static inline bool kk_bits_popcount_is_even32(uint32_t x) { + return ((kk_bits_popcount32(x) & 1) == 0); } -static inline bool kk_bits_count_is_even64(uint64_t x) { - return ((kk_bits_count64(x) & 1) == 0); +static inline bool kk_bits_popcount_is_even64(uint64_t x) { + return ((kk_bits_popcount64(x) & 1) == 0); } #elif defined(__GNUC__) -static inline bool kk_bits_count_is_even32(uint32_t x) { +static inline bool kk_bits_popcount_is_even32(uint32_t x) { return (__builtin32(parity)(x) == 0); } -static inline bool kk_bits_count_is_even64(uint64_t x) { +static inline bool kk_bits_popcount_is_even64(uint64_t x) { return (__builtin64(parity)(x) == 0); } #else -static inline bool kk_bits_count_is_even32(uint32_t x) { +static inline bool kk_bits_popcount_is_even32(uint32_t x) { x ^= x >> 16; x ^= x >> 8; x ^= x >> 4; x &= 0x0F; return (((0x6996 >> x) & 1) == 0); // 0x6996 = 0b0110100110010110 == "mini" 16 bit lookup table with a bit set if the value has non-even parity } -static inline bool kk_bits_count_is_even64(uint64_t x) { - x ^= x >> 32; - return kk_bits_count_is_even32((uint32_t)x); +static inline bool kk_bits_popcount_is_even64(uint64_t x) { + x ^= (x >> 32); + return kk_bits_popcount_is_even32((uint32_t)x); } #endif -static inline bool kk_bits_count_is_even(kk_uintx_t x) { - return kk_bitsx(count_is_even)(x); +static inline bool kk_bits_popcount_is_even(kk_uintx_t x) { + return kk_bitsx(popcount_is_even)(x); } /* --------------------------------------------------------------- Digits in a decimal representation ------------------------------------------------------------------ */ -kk_decl_export uint8_t kk_bits_digits32(uint32_t x); -kk_decl_export uint8_t kk_bits_digits64(uint64_t x); +kk_decl_export int kk_bits_digits32(uint32_t x); +kk_decl_export int kk_bits_digits64(uint64_t x); -static inline uint8_t kk_bits_digits(kk_uintx_t x) { +static inline int kk_bits_digits(kk_uintx_t x) { return kk_bitsx(digits)(x); } diff --git a/kklib/src/bits.c b/kklib/src/bits.c index 7cf64ed5f..95fba1149 100644 --- a/kklib/src/bits.c +++ b/kklib/src/bits.c @@ -7,14 +7,14 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" -uint32_t kk_bits_generic_count32(uint32_t x) { +int kk_bits_generic_popcount32(uint32_t x) { x = x - ((x >> 1) & KK_U32(0x55555555)); x = (x & KK_U32(0x33333333)) + ((x >> 2) & KK_U32(0x33333333)); x = (x + (x >> 4)) & KK_U32(0x0F0F0F0F); return kk_bits_byte_sum32(x); } -uint64_t kk_bits_generic_count64(uint64_t x) { +int kk_bits_generic_popcount64(uint64_t x) { x = x - ((x >> 1) & KK_U64(0x5555555555555555)); x = (x & KK_U64(0x3333333333333333)) + ((x >> 2) & KK_U64(0x3333333333333333)); x = (x + (x >> 4)) & KK_U64(0x0F0F0F0F0F0F0F0F); @@ -31,19 +31,19 @@ static const kk_uintx_t powers_of_10[] = { #endif }; -uint8_t kk_bits_digits32(uint32_t u) { - static const uint8_t guess[33] = { +int kk_bits_digits32(uint32_t u) { + static const int8_t guess[33] = { 1, 0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, 9, 9, 9 }; - uint8_t count = guess[32 - kk_bits_clz32(u)]; // = 1 + (KU32(9)*(31 - kk_bits_clz32(u)) >> 5); + const int count = guess[32 - kk_bits_clz32(u)]; // = 1 + (KU32(9)*(31 - kk_bits_clz32(u)) >> 5); return (count + (u >= powers_of_10[count] ? 1 : 0)); } -uint8_t kk_bits_digits64(uint64_t u) { - static const uint8_t guess[65] = { +int kk_bits_digits64(uint64_t u) { + static const int8_t guess[65] = { 1, 0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, @@ -52,24 +52,26 @@ uint8_t kk_bits_digits64(uint64_t u) { 15,15,15,15,16,16,16,17,17,17, 18,18,18,18,19 }; - uint8_t count = guess[64 - kk_bits_clz64(u)]; // = 1 + (KU64(1233)*(63 - kk_bits_clz64(u)) >> 12); + const int count = guess[64 - kk_bits_clz64(u)]; // = 1 + (KU64(1233)*(63 - kk_bits_clz64(u)) >> 12); return (count + (u >= powers_of_10[count] ? 1 : 0)); } #if defined(KK_BITS_USE_GENERIC_CTZ_CLZ) -uint8_t kk_bits_ctz32(uint32_t x) { +int kk_bits_ctz32(uint32_t x) { // de Bruijn multiplication, see - static const unsigned char debruijn[32] = { + static const int8_t debruijn[32] = { 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 }; - return debruijn[((x & -(int32_t)x) * KK_U32(0x077CB531)) >> 27]; + if (x == 0) return 32; + x = kk_bits_only_keep_lsb32(x); + return debruijn[(uint32_t)(x * KK_U32(0x077CB531)) >> 27]; } -uint8_t kk_bits_clz32(uint32_t x) { +int kk_bits_clz32(uint32_t x) { // de Bruijn multiplication, see - static const uint8_t debruijn[32] = { + static const int8_t debruijn[32] = { 31, 22, 30, 21, 18, 10, 29, 2, 20, 17, 15, 13, 9, 6, 28, 1, 23, 19, 11, 3, 16, 14, 7, 24, 12, 4, 8, 25, 5, 26, 27, 0 }; diff --git a/kklib/test/main.c b/kklib/test/main.c index 09a60ee9d..1db1c8c20 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -392,18 +392,18 @@ static void test_bitcount(void) { uint32_t values[] = { 1,0x80000000,0xFFFFFFFF,0xFFFF,0xFFFF0000,0x7FFFFFFF,0xFFFFFFFE, 0x7FFFFFFE, 0x80000001, 0 }; size_t i = 0; uint32_t v; - uint8_t l, t; + int l, t; do { v = values[i++]; l = kk_bits_clz32(v); t = kk_bits_ctz32(v); if (v == 0) assert((l + t) == 64); - printf("value: 0x%08x, ctz: %2u, clz: %2u\n", v, t, l); + printf("value: 0x%08x, ctz: %2d, clz: %2d\n", v, t, l); } while (v != 0); for (v = 1; v != 0; v <<= 1) { l = kk_bits_clz32(v); t = kk_bits_ctz32(v); - printf("value: 0x%08x, ctz: %2u, clz: %2u\n", v, t, l); + printf("value: 0x%08x, ctz: %2d, clz: %2d\n", v, t, l); assert((l + t) == 31); } } @@ -411,8 +411,8 @@ static void test_bitcount(void) { static void test_popcount(void) { printf("testing popcount..."); fflush(stdout); for (uint32_t i = 0; i < UINT32_MAX; i++) { - uint32_t c1 = kk_bits_generic_count32(i); - uint32_t c2 = kk_bits_count32(i); + int c1 = kk_bits_generic_popcount32(i); + int c2 = kk_bits_popcount32(i); if (c1 != c2) { assert(c1 == c2); abort(); @@ -689,7 +689,7 @@ int main() { test_count10(ctx); test_bitcount(); - //test_popcount(); + test_popcount(); //test_random(ctx); //test_duration1(); diff --git a/lib/std/core/core-integer-inline.js b/lib/std/core/core-integer-inline.js index 20739b5ff..a807de7d0 100644 --- a/lib/std/core/core-integer-inline.js +++ b/lib/std/core/core-integer-inline.js @@ -74,21 +74,18 @@ export function _int32_rotr(x,y) { return ((x >>> shift) | (x << (32 - shift))); } -export function _int32_ctz(x) { - var i = (x|0); - i |= (i << 16); - i |= (i << 8); - i |= (i << 4); - i |= (i << 2); - i |= (i << 1); - return ((32 - Math.clz32(~i))|0); -} - export function _int32_clz(x) { return Math.clz32(x); } -export function _int32_bits_count(x) { +export function _int32_ctz(x) { + var i = (x|0); + if (i === 0) return 32; + i = (i & ((~i) + 1)); // keep only least significant bit + return ((31 - Math.clz32(i))|0); +} + +export function _int32_bits_popcount(x) { var i = (x|0); i = i - ((i >> 1) & 0x55555555); i = (i & 0x33333333) + ((i >> 2) & 0x33333333); @@ -156,10 +153,10 @@ export function _int64_clz(x) { } } -export function _int64_bits_count(x) { +export function _int64_bits_popcount(x) { const hi = Number( _int64_shr(x,32n) ); const lo = Number( x & 0xFFFFFFFFn ); - return BigInt(_int32_bits_count(hi) + _int32_bits_count(lo)); + return BigInt(_int32_bits_popcount(hi) + _int32_bits_popcount(lo)); } diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 9a0c9f07d..0bbc8dd6c 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -249,8 +249,8 @@ inline fip extern clz32( i : int32 ) : int32 // Count number of 1-bits. inline fip extern popcount32( i : int32 ) : int32 - c inline "(int32_t)kk_bits_count(#1)" - js "$std_core._int32_bits_count" + c inline "(int32_t)kk_bits_popcount32(#1)" + js "$std_core._int32_bits_popcount" // Count trailing zero bits. Returns 32 if `i` is zero. pub fip fun ctz( i : int32 ) : int diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 7fbc8ee82..7c3deab54 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -267,8 +267,8 @@ inline fip extern clz64( i : int64 ) : int64 // Count number of 1-bits. inline fip extern popcount64( i : int64 ) : int64 - c inline "(int64_t)kk_bits_count(#1)" - js "$std_core._int64_bits_count" + c inline "(int64_t)kk_bits_popcount64(#1)" + js "$std_core._int64_bits_popcount" // Count trailing zero bits. Returns 64 if `i` is zero. pub fip fun ctz( i : int64 ) : int From 1b3617a4cd304ccbb05a2e956313e03dc4574f02 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 1 Jul 2023 12:15:34 -0700 Subject: [PATCH 229/233] update mimalloc --- kklib/mimalloc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kklib/mimalloc b/kklib/mimalloc index 5e09f1b05..10efe291a 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit 5e09f1b051738bd3823e7617cf4cbc6cbb9e762c +Subproject commit 10efe291af16d04301c86d37133e97d77250719b From d4ddadc70446e607069eedc508e3e1f941dc7b66 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 1 Jul 2023 14:22:54 -0700 Subject: [PATCH 230/233] add parity, ffs, clrsb --- kklib/include/kklib.h | 2 +- lib/std/core/core-integer-inline.js | 70 +++++++++++++++++++++++++---- lib/std/num/int32.kk | 35 ++++++++++++--- lib/std/num/int64.kk | 34 ++++++++++++-- 4 files changed, 122 insertions(+), 19 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index d740b38ce..19cb40bb0 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -9,7 +9,7 @@ found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -#define KKLIB_BUILD 113 // modify on changes to trigger recompilation +#define KKLIB_BUILD 114 // modify on changes to trigger recompilation // #define KK_DEBUG_FULL 1 // set to enable full internal debug checks // Includes diff --git a/lib/std/core/core-integer-inline.js b/lib/std/core/core-integer-inline.js index a807de7d0..35532fc69 100644 --- a/lib/std/core/core-integer-inline.js +++ b/lib/std/core/core-integer-inline.js @@ -85,7 +85,26 @@ export function _int32_ctz(x) { return ((31 - Math.clz32(i))|0); } -export function _int32_bits_popcount(x) { +export function _int32_ffs(x) { // find first set bit: bit-index + 1, or 0 for zero + return (x == 0 ? 0 : 1 + _int32_ctz(x)); +} + +export function _int32_clrsb(x) { + var i = (x|0); + i = i ^ (i >> 31); + return (i===0 ? 31 : _int32_clz(i) - 1); +} + +export function _int32_parity(x) { + var i = x|0; + i ^= (i >>> 16); + i ^= (i >>> 8); + i ^= (i >>> 4); + i &= 0x0F; + return (((0x6996 >> x) & 1) === 0); // 0x6996 = 0b0110100110010110 == "mini" 16 bit lookup table with a bit set if the value has non-even parity +} + +export function _int32_popcount(x) { var i = (x|0); i = i - ((i >> 1) & 0x55555555); i = (i & 0x33333333) + ((i >> 2) & 0x33333333); @@ -131,10 +150,18 @@ export function _int64_rotr(x,y) { return _int64_rotl(x, 64n - y); } +function _int64_hi(x) { + return (Number( (x>>32n) & 0xFFFFFFFFn ) | 0); +} + +function _int64_lo(x) { + return (Number( x & 0xFFFFFFFFn ) | 0); +} + export function _int64_ctz(x) { - const lo = Number( x & 0xFFFFFFFFn ); + const lo = _int64_lo(x); if (lo === 0) { - const hi = Number( _int64_shr(x,32n) ); + const hi = _int64_hi(x); return BigInt(32 + _int32_ctz(hi)); } else { @@ -143,9 +170,9 @@ export function _int64_ctz(x) { } export function _int64_clz(x) { - const hi = Number( _int64_shr(x,32n) ); + const hi = _int64_hi(x); if (hi === 0) { - const lo = Number( x & 0xFFFFFFFFn ); + const lo = _int64_lo(x); return BigInt(32 + _int32_clz(lo)); } else { @@ -153,10 +180,35 @@ export function _int64_clz(x) { } } -export function _int64_bits_popcount(x) { - const hi = Number( _int64_shr(x,32n) ); - const lo = Number( x & 0xFFFFFFFFn ); - return BigInt(_int32_bits_popcount(hi) + _int32_bits_popcount(lo)); +export function _int64_ffs(x) { // find first set bit: bit-index + 1, or 0 for zero + return (x === 0n ? 0n : 1n + _int64_ctz(x)); +} + +export function _int64_clrsb(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + if (hi === 0) { + return (lo < 0 ? 31 : 32 + _int32_clrsb(lo)); + } + else if (hi === -1) { + return (lo >= 0 ? 31 : 32 + _int32_clrsb(lo)); + } + else { + return BigInt(_int32_clrsb(hi)); + } +} + +export function _int64_parity(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + const i = (lo ^ hi); + return _int32_parity(i); +} + +export function _int64_popcount(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + return BigInt(_int32_popcount(hi) + _int32_popcount(lo)); } diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 0bbc8dd6c..f2e9cd12a 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -247,11 +247,6 @@ inline fip extern clz32( i : int32 ) : int32 c inline "(int32_t)kk_bits_clz32(#1)" js "$std_core._int32_clz" -// Count number of 1-bits. -inline fip extern popcount32( i : int32 ) : int32 - c inline "(int32_t)kk_bits_popcount32(#1)" - js "$std_core._int32_bits_popcount" - // Count trailing zero bits. Returns 32 if `i` is zero. pub fip fun ctz( i : int32 ) : int ctz32(i).int @@ -260,10 +255,40 @@ pub fip fun ctz( i : int32 ) : int pub fip fun clz( i : int32 ) : int clz32(i).int +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +inline fip extern ffs32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_ffs32(#1)" + js "$std_core._int32_ffs" + +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +pub fip fun ffs( i : int32 ) : int + ffs32(i).int + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +inline fip extern clrsb32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_clrsb32(#1)" + js "$std_core._int32_clrsb" + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +pub fip fun clrsb( i : int32 ) : int + clrsb32(i).int + +// Count number of 1-bits. +inline fip extern popcount32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_popcount32(#1)" + js "$std_core._int32_bits_popcount" + // Count number of 1-bits. pub fip fun popcount( i : int32 ) : int popcount32(i).int +// Is the number of 1-bits even? +pub inline fip extern parity( i : int32 ) : bool + c inline "kk_bits_popcount_is_even32(#1)" + js "$std_core._int32_parity" + // Return the minimum of two integers pub fip fun min( i : int32, j : int32 ) : int32 diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 7c3deab54..21652bc45 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -265,10 +265,16 @@ inline fip extern clz64( i : int64 ) : int64 c inline "(int64_t)kk_bits_clz64(#1)" js "$std_core._int64_clz" -// Count number of 1-bits. -inline fip extern popcount64( i : int64 ) : int64 - c inline "(int64_t)kk_bits_popcount64(#1)" - js "$std_core._int64_bits_popcount" +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +inline fip extern ffs64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_ffs64(#1)" + js "$std_core._int64_ffs" + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +inline fip extern clrsb64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_clrsb64(#1)" + js "$std_core._int64_clrsb" // Count trailing zero bits. Returns 64 if `i` is zero. pub fip fun ctz( i : int64 ) : int @@ -278,10 +284,30 @@ pub fip fun ctz( i : int64 ) : int pub fip fun clz( i : int64 ) : int clz64(i).int +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +pub fip fun ffs( i : int64 ) : int + ffs64(i).int + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +pub fip fun clrsb( i : int64 ) : int + clrsb64(i).int + + +// Count number of 1-bits. +inline fip extern popcount64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_popcount64(#1)" + js "$std_core._int64_popcount" + // Count number of 1-bits. pub fip fun popcount( i : int64 ) : int popcount64(i).int +// Is the number of 1-bits even? +pub inline fip extern parity( i : int64 ) : bool + c inline "kk_bits_popcount_is_even64(#1)" + js "$std_core._int64_parity" + // Return the minimum of two integers From 914fa2aa2ca415be1e7e58909aaf8a5fafea5323 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 3 Jul 2023 08:53:50 -0700 Subject: [PATCH 231/233] fix warning on older gcc --- kklib/include/kklib/platform.h | 1 - util/README.md | 31 +++++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) create mode 100644 util/README.md diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 9887247c1..7dbaf6aab 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -171,7 +171,6 @@ #pragma GCC diagnostic ignored "-Wunused-variable" #pragma GCC diagnostic ignored "-Wunused-value" #pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals -#pragma GCC diagnostic ignored "-Waddress-of-packed-member" #define kk_decl_const __attribute__((const)) // reads no global state at all #define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects #define kk_decl_noinline __attribute__((noinline)) diff --git a/util/README.md b/util/README.md new file mode 100644 index 000000000..de74d1ba5 --- /dev/null +++ b/util/README.md @@ -0,0 +1,31 @@ +# Utilities + +- `bundle.kk`: creates a fresh release bundle. +- `install.`[`bat`,`sh`]: installer scripts that install bundles. +- `minbuild.sh`: a script to run a build with minimal dependencies (if you don't have `stack` or `cabal`). +- `link-`[`min`,`test`,`std`]: wrapper module to build and link most standard libraries for an install bundle. +- `grammar.kk`: build and test the yacc & flex grammar. +- `packaging`: build packages for various Linux distributions. + + +# Releasing + +Compile Koka: + +``` +$ stack build +$ stack exec koka + +// check if interpreter works +> :q + +$ stack exec test +``` + +and create a bundle: + +``` +$ stack exec koka -- -e util/bundle.kk +``` + +Copy the bundles from `bundle/v/koka-v--.tar.gz` and upload them. From 248780d3e4e19db7ca69a04aff38662dc1ec1909 Mon Sep 17 00:00:00 2001 From: Daan Leijen Date: Mon, 3 Jul 2023 09:17:44 -0700 Subject: [PATCH 232/233] fix warning on mingw --- kklib/src/all.c | 2 +- kklib/src/thread.c | 1 + util/README.md | 9 ++++++--- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/kklib/src/all.c b/kklib/src/all.c index 6f0846cf7..cb6e1eb55 100644 --- a/kklib/src/all.c +++ b/kklib/src/all.c @@ -7,7 +7,7 @@ ---------------------------------------------------------------------------*/ #define _BSD_SOURCE #define _DEFAULT_SOURCE -#define __USE_MINGW_ANSI_STDIO // so %z is valid on mingw +#define __USE_MINGW_ANSI_STDIO 1 // so %z is valid on mingw #if defined(KK_MIMALLOC) #if !defined(MI_MAX_ALIGN_SIZE) diff --git a/kklib/src/thread.c b/kklib/src/thread.c index dd9ae420f..08807e8c5 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -14,6 +14,7 @@ ---------------------------------------------------------------------------*/ #ifdef _WIN32 #include +#include // -------------------------------------- // Threads diff --git a/util/README.md b/util/README.md index de74d1ba5..2e4513104 100644 --- a/util/README.md +++ b/util/README.md @@ -14,12 +14,15 @@ Compile Koka: ``` $ stack build -$ stack exec koka +$ stack exec koka # check if interpreter works + +> :l samples/all +> all/main() +... -// check if interpreter works > :q -$ stack exec test +$ stack test ``` and create a bundle: From 3360ddf325d77114e9fdc0a4fa34169c9768c7fd Mon Sep 17 00:00:00 2001 From: daanx Date: Mon, 3 Jul 2023 10:20:00 -0700 Subject: [PATCH 233/233] update readme --- readme.md | 17 ++++++---- util/README.md | 91 +++++++++++++++++++++++++++++++------------------- 2 files changed, 68 insertions(+), 40 deletions(-) diff --git a/readme.md b/readme.md index d6f835cad..5376dd3b6 100644 --- a/readme.md +++ b/readme.md @@ -15,7 +15,7 @@ # Koka: a Functional Language with Effects _Koka v2 is a research language that currently under heavy development with the new C backend_ -_Latest release_: v2.4.0, 2022-02-07 ([Install]). +_Latest release_: v2.4.2, 2023-07-03 ([Install]). @@ -85,6 +85,9 @@ and all previous interns working on earlier versions of Koka: Daniel Hillerströ ## Recent Releases +* `v2.4.2`, 2023-07-03: interim release with support for the new `fip` and `fbip` keywords + to support fully-in-place programming [[11](#references)]. Various bug fixes and performance + enhancements. * `v2.4.0`, 2022-02-07: improved specialization and integer add/sub, add `rbtree-fbip` sample, improve grammar (`pub` (instead of `public`, remove private (as it is always default)), `final ctl` (instead of `brk`), underscores in number literals, etc), @@ -126,7 +129,7 @@ and all previous interns working on earlier versions of Koka: Daniel Hillerströ # Install -Koka has [binary installers][install] for Windows (x64), macOS (x64, M1), Linux (x64, arm64), and FreeBSD (x64). +Koka has [binary installers][install] for Windows (x64), macOS (x64, M1), and Linux (x64) For other platforms, you need to build the compiler from source. # Build from Source @@ -276,8 +279,6 @@ More advanced projects: needs work on packaging it to make it easy to build and install as part of the Koka installer. * [ ] Package management of Koka modules. * [x] Compile to WASM (using emscripten on the current C backend) -* [ ] Extend TRMC to include (1) return results with pairs (like `unzip` or `partition`), (2) associative functions - (like `+` in `length`), and (3) mutually recursive functions. * [ ] Improve compilation of local state to use local variables directly (in C) without allocation. Tricky though due to multiple resumptions. * [ ] Improve performance of array/mutable reference programming. Koka is has great performance for algebraic datatypes but lags when using more imperative array algorithms. This requires better @@ -293,7 +294,7 @@ More advanced projects: Master/PhD level: -* [ ] Better language level FBIP support with guaranteed datatype matching, automatic derivative and visitor generation. +* [x] Better language level FBIP support with guaranteed datatype matching, automatic derivative and visitor generation. * [ ] Can we use C++ exceptions to implement "zero-cost" `if yielding() ...` branches and remove the need join points (see [9]). * [x] Float up `open` calls to improve effect handling (worked on by Naoya Furudono) * [x] Formalize opening and closing effect row types (worked on by Kazuki Ikemori) @@ -327,7 +328,7 @@ The main development branches are: ## Building on macOS M1 -You need at least `stack` version 2.7.4. +You need at least `stack` version >= 2.11 Furthermore, you may need to add the `brew` installed LLVM to your path afterwards, or otherwise stack cannot find the LLVM tools. Add the following to your `~/.zshrc` script and open an fresh prompt: @@ -505,3 +506,7 @@ Also as MSR-TR-2021-5, Mar, 2021. 10. Anton Lorenzen and Daan Leijen. “ Reference Counting with Frame-Limited Reuse” Microsoft Research technical report MSR-TR-2021-30, Nov 2021, (updated Mar 2022, v2). [pdf](https://www.microsoft.com/en-us/research/publication/reference-counting-with-frame-limited-reuse-extended-version/) + +11. Anton Lorenzen, Daan Leijen, and Wouter Swierstra. “ FP2: Fully in-Place Functional Programming” +The 28th ACM SIGPLAN International Conference on Functional Programming (ICFP), September 2023. +[pdf](https://www.microsoft.com/en-us/research/uploads/prod/2023/05/fbip.pdf) (extended tech. report MSR-TR-2023-19, May 2023). diff --git a/util/README.md b/util/README.md index 2e4513104..91198f9e2 100644 --- a/util/README.md +++ b/util/README.md @@ -1,34 +1,57 @@ -# Utilities - -- `bundle.kk`: creates a fresh release bundle. -- `install.`[`bat`,`sh`]: installer scripts that install bundles. -- `minbuild.sh`: a script to run a build with minimal dependencies (if you don't have `stack` or `cabal`). -- `link-`[`min`,`test`,`std`]: wrapper module to build and link most standard libraries for an install bundle. -- `grammar.kk`: build and test the yacc & flex grammar. -- `packaging`: build packages for various Linux distributions. - - -# Releasing - -Compile Koka: - -``` -$ stack build -$ stack exec koka # check if interpreter works - -> :l samples/all -> all/main() -... - -> :q - -$ stack test -``` - -and create a bundle: - -``` -$ stack exec koka -- -e util/bundle.kk -``` - -Copy the bundles from `bundle/v/koka-v--.tar.gz` and upload them. +# Utilities + +- `bundle.kk`: creates a fresh release bundle. +- `install.`[`bat`,`sh`]: installer scripts that install bundles. +- `minbuild.sh`: a script to run a build with minimal dependencies (if you don't have `stack` or `cabal`). +- `link-`[`min`,`test`,`std`]: wrapper module to build and link most standard libraries for an install bundle. +- `grammar.kk`: build and test the yacc & flex grammar. +- `packaging`: build packages for various Linux distributions. + + +# Releasing + +Ensure latest stack: + +``` +$ stack upgrade +$ stack update +``` + +Bump the Koka version in files: + +- `package.yaml` (2 places!) +- `util/install.sh` +- `util/install.bat` +- `util/Dockerfile` +- `util/minbuild.sh` + +Compile Koka: + +``` +$ stack build +$ stack exec koka # check if interpreter works + +> :l samples/all +> all/main() +... + +> :q + +$ stack test +``` + +and create a bundle: + +``` +$ stack exec koka -- -e util/bundle.kk +``` + +(On Windows, to this in an Visual Studio x64 command line tools console). + +Test installation: + +``` +$ util/install.sh ./bundle/v/koka-v--.tar.gz +``` + +Copy the bundles from `bundle/v/koka-v--.tar.gz` and upload them.