├── .gitignore
├── LICENSE
├── README.md
├── Setup.hs
├── cbits
    ├── ghc_cleanup.c
    └── ghc_init.c
├── include
    ├── glaswegian++.h
    └── glaswegian.h
├── libglaswegian.cabal
├── shell.nix
├── src
    └── Glaswegian.hs
└── test
    ├── main.c
    └── main.cc


/.gitignore:
--------------------------------------------------------------------------------
1 | **/*.swp
2 | dist
3 | dist-newstyle
4 | .stack-work
5 | **/TAGS
6 | **/#*#
7 | **/*~
8 | cabal.project.local*
9 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2020 Travis Whitaker
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining
 4 | a copy of this software and associated documentation files (the
 5 | "Software"), to deal in the Software without restriction, including
 6 | without limitation the rights to use, copy, modify, merge, publish,
 7 | distribute, sublicense, and/or sell copies of the Software, and to
 8 | permit persons to whom the Software is furnished to do so, subject to
 9 | the following conditions:
10 | 
11 | The above copyright notice and this permission notice shall be included
12 | in all copies or substantial portions of the Software.
13 | 
14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # libglaswegian
 2 | 
 3 | Use GHC's Memory Allocator from C/C++. Yes, I'm serious. You can do this:
 4 | 
 5 | ```c++
 6 | #include <iostream>
 7 | #include <vector>
 8 | 
 9 | #include <glaswegian++.h>
10 | 
11 | #define LEN 4096
12 | 
13 | int main()
14 | {
15 |     ghc_init();
16 |     std::vector<double, GlaswegianAllocator<double>> xs;
17 |     for(int i = 0; i < LEN; i++)
18 |     {
19 |         xs.emplace_back(i * i);
20 |     }
21 |     double s = 0;
22 |     for(double i : xs)
23 |     {
24 |         s += i;
25 |     }
26 |     std::cout << s << std::endl;
27 |     return 0;
28 | }
29 | ```
30 | 
31 | This works by allocating pinned `MutableByteArray#`s, then sticking a
32 | `StablePtr` into a radix tree with the `MutableByteArray#`'s address as the key.
33 | This keeps the array alive on the heap until the caller frees the memory (which
34 | just deletes the `StablePtr` from the tree and does `freeStablePtr`).
35 | 
36 | A further optimization might be to call the RTS' C functions for doing
37 | allocations directly, but this library is *shockingly* competitive with other
38 | memory allocators. I'll add benchmarks soon.
39 | 
40 | This library is a fun toy I made for some silly benchmarks I wanted to run. It
41 | is probably only useful for getting your colleagues to shut up about how
42 | "garbage collectors are slow."
43 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/cbits/ghc_cleanup.c:
--------------------------------------------------------------------------------
1 | #include <HsFFI.h>
2 | 
3 | void ghc_cleanup()
4 | {
5 |     hs_exit();
6 | }
7 | 


--------------------------------------------------------------------------------
/cbits/ghc_init.c:
--------------------------------------------------------------------------------
 1 | #include <HsFFI.h>
 2 | #include <Rts.h>
 3 | 
 4 | void ghc_init()
 5 | {
 6 |     RtsConfig conf = defaultRtsConfig;
 7 |     conf.rts_opts_enabled = RtsOptsAll;
 8 |     int argc = 3;
 9 |     char* argv[] = { "libglaswegian", "+RTS", "-A256M", 0};
10 |     char** rargv = argv;
11 |     hs_init_ghc(&argc, &rargv, conf);
12 | }
13 | 


--------------------------------------------------------------------------------
/include/glaswegian++.h:
--------------------------------------------------------------------------------
 1 | #include <limits>
 2 | 
 3 | extern "C"
 4 | {
 5 | #include <glaswegian.h>
 6 | };
 7 | 
 8 | // Call ghc_init before constructing one of these.
 9 | template <typename a>
10 | struct GlaswegianAllocator
11 | {
12 |     typedef a value_type;
13 | 
14 |     GlaswegianAllocator() = default;
15 | 
16 |     a* allocate(std::size_t n)
17 |     {
18 |         if(n > std::numeric_limits<std::size_t>::max() / sizeof(a))
19 |         {
20 |             throw std::bad_alloc();
21 |         }
22 |         if(auto p = static_cast<a*>(ghc_alloc(n*sizeof(a))))
23 |         {
24 |             return p;
25 |         }
26 |         throw std::bad_alloc();
27 |     }
28 |     void deallocate(a* p, std::size_t) noexcept
29 |     {
30 |         ghc_free(p);
31 |     }
32 | };
33 | 
34 | template <typename a, typename b>
35 | bool operator==(const GlaswegianAllocator<a>&, const GlaswegianAllocator<b>&)
36 | {
37 |     return true;
38 | }
39 | template <typename a, typename b>
40 | bool operator!=(const GlaswegianAllocator<a>&, const GlaswegianAllocator<b>&)
41 | {
42 |     return false;
43 | }
44 | 


--------------------------------------------------------------------------------
/include/glaswegian.h:
--------------------------------------------------------------------------------
 1 | // Start the RTS.
 2 | void ghc_init();
 3 | 
 4 | // Stop the RTS.
 5 | void ghc_cleanup();
 6 | 
 7 | // Like malloc() but better!
 8 | void* ghc_alloc(size_t);
 9 | 
10 | // Like free() but better!
11 | void ghc_free(void*);
12 | 


--------------------------------------------------------------------------------
/libglaswegian.cabal:
--------------------------------------------------------------------------------
 1 | cabal-version:       2.2
 2 | 
 3 | name:                libglaswegian
 4 | version:             0.1.0.0
 5 | synopsis:            Use GHC's memory allocator from C.
 6 | description:         Use GHC's memory allocator from C.
 7 | homepage:            https://github.com/TravisWhitaker/libglaswegian
 8 | bug-reports:         https://github.com/TravisWhitaker/libglaswegian/issues
 9 | license:             MIT
10 | license-file:        LICENSE
11 | author:              Travis Whitaker
12 | maintainer:          pi.boy.travis@gmail.com
13 | copyright:           Travis Whitaker 2020
14 | category:            System
15 | extra-source-files:  CHANGELOG.md, README.md
16 | 
17 | foreign-library glaswegian
18 |   type:                native-shared
19 |   -- options:             standalone
20 |   other-modules:       Glaswegian
21 |   build-depends:       base ^>=4.13.0.0
22 |                      , containers
23 |                      , primitive
24 |   hs-source-dirs:      src
25 |   default-language:    Haskell2010
26 |   c-sources:           cbits/ghc_init.c
27 |                        cbits/ghc_cleanup.c
28 |   include-dirs:        include
29 |   install-includes:    glaswegian.h
30 |                        glaswegian++.h
31 |   ghc-options:         -O2
32 |                        -threaded
33 |                        -Wall
34 |                        -Widentities
35 |                        -Wredundant-constraints
36 |                        -Wcompat
37 |                        -Wno-type-defaults
38 |                        -Wno-unused-local-binds
39 |                        -Wno-unused-do-bind
40 |                        -Wno-unused-matches
41 |                        -Werror
42 |                        -threaded
43 |   if (os(darwin))
44 |     ghc-options: -optP-Wno-nonportable-include-path
45 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | let pinned-nixpkgs = builtins.fetchGit
 2 |     {
 3 |         url = "https://github.com/nixos/nixpkgs";
 4 |         ref = "master";
 5 |         rev = "1fe82110febdf005d97b2927610ee854a38a8f26";
 6 |     };
 7 | in with import pinned-nixpkgs {};
 8 | runCommand "libglaswegian-env"
 9 | {
10 |     buildInputs =
11 |         let thisghc = haskell.packages.ghc882.ghcWithPackages
12 |             (p: [ p.cabal-install
13 |                   p.ghci
14 |                 ]);
15 |         in [ binutils
16 |              thisghc
17 |            ];
18 | } ""
19 | 


--------------------------------------------------------------------------------
/src/Glaswegian.hs:
--------------------------------------------------------------------------------
 1 | module Glaswegian where
 2 | 
 3 | import Control.Monad.Primitive
 4 | 
 5 | import Data.Coerce
 6 | 
 7 | import qualified Data.IntMap.Strict as IM
 8 | 
 9 | import Data.IORef
10 | 
11 | import Data.Primitive.ByteArray
12 | 
13 | import Foreign.C.Types
14 | import Foreign.Ptr
15 | import Foreign.StablePtr
16 | 
17 | import System.IO.Unsafe
18 | 
19 | type IOMBA = MutableByteArray RealWorld
20 | 
21 | type VoidStar = Ptr ()
22 | 
23 | stabTab :: IORef (IM.IntMap (StablePtr IOMBA))
24 | stabTab = unsafePerformIO (newIORef IM.empty)
25 | 
26 | ghc_alloc :: CSize -> IO VoidStar
27 | ghc_alloc s = do
28 |     mba <- newPinnedByteArray (fromIntegral s)
29 |     sp <- newStablePtr mba
30 |     let mbac = castPtr (mutableByteArrayContents mba)
31 |         ip   = coerce (ptrToIntPtr mbac)
32 |     atomicModifyIORef' stabTab (\t -> (IM.insert ip sp t,()))
33 |     pure mbac
34 | 
35 | foreign export ccall ghc_alloc :: CSize -> IO VoidStar
36 | 
37 | -- ghc_realloc ::
38 | 
39 | ghc_free :: VoidStar -> IO ()
40 | ghc_free mbac = do
41 |     let ip = coerce (ptrToIntPtr mbac)
42 |         f t =
43 |             let (Just sp, t') = IM.updateLookupWithKey (\_ _ -> Nothing) ip t
44 |             in (t', sp)
45 |     sp <- atomicModifyIORef' stabTab f
46 |     freeStablePtr sp
47 | 
48 | foreign export ccall ghc_free :: VoidStar -> IO ()
49 | 


--------------------------------------------------------------------------------
/test/main.c:
--------------------------------------------------------------------------------
 1 | #include <stdio.h>
 2 | 
 3 | #include <glaswegian.h>
 4 | 
 5 | #define LEN 4096
 6 | 
 7 | int main()
 8 | {
 9 |     ghc_init();
10 |     double* xs = ghc_alloc(sizeof(*xs) * LEN);
11 |     for(int i = 0; i < LEN; i++)
12 |     {
13 |         xs[i] = i * i;
14 |     }
15 |     double s = 0;
16 |     for(int i = 0; i < LEN; i++)
17 |     {
18 |         s += xs[i];
19 |     }
20 |     ghc_free(xs);
21 |     ghc_cleanup();
22 |     printf("%f\n", s);
23 |     return 0;
24 | }
25 | 


--------------------------------------------------------------------------------
/test/main.cc:
--------------------------------------------------------------------------------
 1 | #include <iostream>
 2 | #include <vector>
 3 | 
 4 | #include <glaswegian++.h>
 5 | 
 6 | #define LEN 4096
 7 | 
 8 | int main()
 9 | {
10 |     ghc_init();
11 |     std::vector<double, GlaswegianAllocator<double>> xs;
12 |     for(int i = 0; i < LEN; i++)
13 |     {
14 |         xs.emplace_back(i * i);
15 |     }
16 |     double s = 0;
17 |     for(double i : xs)
18 |     {
19 |         s += i;
20 |     }
21 |     std::cout << s << std::endl;
22 |     return 0;
23 | }
24 | 


--------------------------------------------------------------------------------