Make this horrible thing.

.gitignore

@@ -0,0 +1,8 @@
+**/*.swp
+dist
+dist-newstyle
+.stack-work
+**/TAGS
+**/#*#
+**/*~
+cabal.project.local*

LICENSE

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

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

cbits/ghc_cleanup.c

@@ -0,0 +1,6 @@
+#include <HsFFI.h>
+
+void ghc_cleanup()
+{
+    hs_exit();
+}

cbits/ghc_init.c

@@ -0,0 +1,12 @@
+#include <HsFFI.h>
+#include <Rts.h>
+
+void ghc_init()
+{
+    RtsConfig conf = defaultRtsConfig;
+    conf.rts_opts_enabled = RtsOptsAll;
+    int argc = 3;
+    char* argv[] = { "libglaswegian", "+RTS", "-A256M", 0};
+    char** rargv = argv;
+    hs_init_ghc(&argc, &rargv, conf);
+}

include/glaswegian.h

@@ -0,0 +1,11 @@
+// Start the RTS.
+void ghc_init();
+
+// Stop the RTS.
+void ghc_cleanup();
+
+// Like malloc() but better!
+void* ghc_alloc(size_t);
+
+// Like free() but better!
+void ghc_free(void*);

libglaswegian.cabal

@@ -0,0 +1,43 @@
+cabal-version:       2.2
+
+name:                libglaswegian
+version:             0.1.0.0
+synopsis:            Use GHC's memory allocator from C.
+description:         Use GHC's memory allocator from C.
+homepage:            https://github.com/TravisWhitaker/libglaswegian
+bug-reports:         https://github.com/TravisWhitaker/libglaswegian/issues
+license:             MIT
+license-file:        LICENSE
+author:              Travis Whitaker
+maintainer:          [email protected]
+copyright:           Travis Whitaker 2020
+category:            System
+extra-source-files:  CHANGELOG.md, README.md
+
+foreign-library glaswegian
+  type:                native-shared
+  -- options:             standalone
+  other-modules:       Glaswegian
+  build-depends:       base ^>=4.13.0.0
+                     , containers
+                     , primitive
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  c-sources:           cbits/ghc_init.c
+                       cbits/ghc_cleanup.c
+  include-dirs:        include
+  install-includes:    glaswegian.h
+  ghc-options:         -O2
+                       -threaded
+                       -Wall
+                       -Widentities
+                       -Wredundant-constraints
+                       -Wcompat
+                       -Wno-type-defaults
+                       -Wno-unused-local-binds
+                       -Wno-unused-do-bind
+                       -Wno-unused-matches
+                       -Werror
+                       -threaded
+  if (os(darwin))
+    ghc-options: -optP-Wno-nonportable-include-path

shell.nix

@@ -0,0 +1,18 @@
+let pinned-nixpkgs = builtins.fetchGit
+    {
+        url = "https://github.com/nixos/nixpkgs";
+        ref = "master";
+        rev = "1fe82110febdf005d97b2927610ee854a38a8f26";
+    };
+in with import pinned-nixpkgs {};
+runCommand "libglaswegian-env"
+{
+    buildInputs =
+        let thisghc = haskell.packages.ghc882.ghcWithPackages
+            (p: [ p.cabal-install
+                  p.ghci
+                ]);
+        in [ binutils
+             thisghc
+           ];
+} ""

src/Glaswegian.hs

@@ -0,0 +1,48 @@
+module Glaswegian where
+
+import Control.Monad.Primitive
+
+import Data.Coerce
+
+import qualified Data.IntMap.Strict as IM
+
+import Data.IORef
+
+import Data.Primitive.ByteArray
+
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.StablePtr
+
+import System.IO.Unsafe
+
+type IOMBA = MutableByteArray RealWorld
+
+type VoidStar = Ptr ()
+
+stabTab :: IORef (IM.IntMap (StablePtr IOMBA))
+stabTab = unsafePerformIO (newIORef IM.empty)
+
+ghc_alloc :: CSize -> IO VoidStar
+ghc_alloc s = do
+    mba <- newPinnedByteArray (fromIntegral s)
+    sp <- newStablePtr mba
+    let mbac = castPtr (mutableByteArrayContents mba)
+        ip   = coerce (ptrToIntPtr mbac)
+    atomicModifyIORef' stabTab (\t -> (IM.insert ip sp t,()))
+    pure mbac
+
+foreign export ccall ghc_alloc :: CSize -> IO VoidStar
+
+-- ghc_realloc ::
+
+ghc_free :: VoidStar -> IO ()
+ghc_free mbac = do
+    let ip = coerce (ptrToIntPtr mbac)
+        f t =
+            let (Just sp, t') = IM.updateLookupWithKey (\_ _ -> Nothing) ip t
+            in (t', sp)
+    sp <- atomicModifyIORef' stabTab f
+    freeStablePtr sp
+
+foreign export ccall ghc_free :: VoidStar -> IO ()

test/main.c

@@ -0,0 +1,24 @@
+#include <stdio.h>
+
+#include <glaswegian.h>
+
+#define LEN 4096
+
+int main()
+{
+    ghc_init();
+    double* xs = ghc_alloc(sizeof(*xs) * LEN);
+    for(int i = 0; i < LEN; i++)
+    {
+        xs[i] = i * i;
+    }
+    double s = 0;
+    for(int i = 0; i < LEN; i++)
+    {
+        s += xs[i];
+    }
+    ghc_free(xs);
+    ghc_cleanup();
+    printf("%f\n", s);
+    return 0;
+}