From 7bfceecfb9d680a6d89e84c354daaeb593e72a09 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Tue, 25 Apr 2023 05:29:25 -0400 Subject: [PATCH 1/8] Minor edits to the plugin --- gibbon-ghc-integration/examples/gibbon-examples.cabal | 2 +- gibbon-ghc-integration/examples/src/BinTree.hs | 2 +- gibbon-ghc-integration/plugin0/plugin0.cabal | 2 +- .../plugin0/src/Gibbon/{Plugin.hs => Plugin0.hs} | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) rename gibbon-ghc-integration/plugin0/src/Gibbon/{Plugin.hs => Plugin0.hs} (98%) diff --git a/gibbon-ghc-integration/examples/gibbon-examples.cabal b/gibbon-ghc-integration/examples/gibbon-examples.cabal index 395a48c4e..8264e44aa 100644 --- a/gibbon-ghc-integration/examples/gibbon-examples.cabal +++ b/gibbon-ghc-integration/examples/gibbon-examples.cabal @@ -15,7 +15,7 @@ library ghc-options: -Wall -Wcompat -fdefer-typed-holes default-language: Haskell2010 ghc-options: -Wall -Wcompat - -fplugin=Gibbon.Plugin + -fplugin=Gibbon.Plugin0 -fplugin=Gibbon.Plugin1 "-optl-Wl,--allow-multiple-definition" diff --git a/gibbon-ghc-integration/examples/src/BinTree.hs b/gibbon-ghc-integration/examples/src/BinTree.hs index 39e567a41..5f2503dc5 100644 --- a/gibbon-ghc-integration/examples/src/BinTree.hs +++ b/gibbon-ghc-integration/examples/src/BinTree.hs @@ -4,7 +4,7 @@ module BinTree where -import Gibbon.Plugin ( PackedAnn(..) ) +import Gibbon.Plugin0 ( PackedAnn(..) ) import Foreign import Foreign.C.Types import GHC.Generics diff --git a/gibbon-ghc-integration/plugin0/plugin0.cabal b/gibbon-ghc-integration/plugin0/plugin0.cabal index 94ca03afb..69c742920 100644 --- a/gibbon-ghc-integration/plugin0/plugin0.cabal +++ b/gibbon-ghc-integration/plugin0/plugin0.cabal @@ -6,7 +6,7 @@ maintainer: ckoparkar@gmail.com build-type: Simple library - exposed-modules: Gibbon.Plugin + exposed-modules: Gibbon.Plugin0 other-modules: Gibbon.CoreToL0 Gibbon.Utils hs-source-dirs: src diff --git a/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin.hs b/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs similarity index 98% rename from gibbon-ghc-integration/plugin0/src/Gibbon/Plugin.hs rename to gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs index fe389ae71..4850b4770 100644 --- a/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin.hs +++ b/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Gibbon.Plugin ( plugin, PackedAnn(..) ) where +module Gibbon.Plugin0 ( plugin, PackedAnn(..) ) where import qualified GHC.Types.TyThing as GHC import qualified GHC.Unit.External as GHC @@ -31,7 +31,7 @@ gibbonCoreTodo = GHC.CoreDoPluginPass "GibbonLiftPacked" test where test :: GHC.ModGuts -> GHC.CoreM GHC.ModGuts test mod_guts = do - GHC.liftIO $ print "[Gibbon Core Plugin] Starting..." + GHC.liftIO $ print "[Gibbon Core Plugin (0)] Starting..." -- Things defined in other modules and libraries. hsc_env <- GHC.getHscEnv From f0d20a73377d5e2dac31e878a46284c6a3ba5d8f Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Tue, 25 Apr 2023 15:55:55 -0400 Subject: [PATCH 2/8] wip: GHC integration --- gibbon-compiler/src/Gibbon/Common.hs | 1 + gibbon-compiler/src/Gibbon/Compiler.hs | 24 +- gibbon-compiler/src/Gibbon/Passes/Codegen.hs | 3 +- .../src/Gibbon/Passes/Simplifier.hs | 4 +- gibbon-compiler/src/Gibbon/Pretty.hs | 5 +- gibbon-ghc-integration/cabal.project | 1 + gibbon-ghc-integration/examples/app/Main.hs | 23 +- .../examples/app/Measure.hs | 108 ++++ .../examples/gibbon-examples.cabal | 42 +- .../examples/src/BinTree.hs | 60 ++- .../gibbon-plugin/gibbon-plugin.cabal | 21 + .../gibbon-plugin/src/Gibbon/Plugin.hs | 466 ++++++++++++++++++ .../plugin0/src/Gibbon/Plugin0.hs | 6 + gibbon-rts/Makefile | 2 +- gibbon-rts/rts-c/gibbon_rts.h | 12 +- 15 files changed, 724 insertions(+), 54 deletions(-) create mode 100644 gibbon-ghc-integration/examples/app/Measure.hs create mode 100644 gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal create mode 100644 gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index 12460476c..c5cc1ed14 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -252,6 +252,7 @@ data Mode = ToParse -- ^ Parse and then stop | RunMPL -- ^ Compile to SML & compile with MPL & run | Bench Var -- ^ Benchmark a particular function applied to the packed data within an input file. | BenchInput FilePath -- ^ Hardcode the input file to the benchmark in the C code. + | Library Var -- ^ Compile as a library, with its main entry point given. deriving (Show, Read, Eq, Ord) -- | Compilation backend used diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 6c2e8290d..28c0fa532 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -9,7 +9,7 @@ module Gibbon.Compiler ( -- * Compiler entrypoints - compile, compileCmd + compile, compileFromL0, compileCmd -- * Configuration options and parsing , Config (..), Mode(..), Input(..) , configParser, configWithArgs, defaultConfig @@ -163,7 +163,8 @@ configParser = Config <$> inputParser flag' RunMPL (long "mpl-run" <> help "Emit SML, compile with MPL, and run") <|> (Bench . toVar <$> strOption (short 'b' <> long "bench-fun" <> metavar "FUN" <> help ("Generate code to benchmark a 1-argument FUN against a input packed file."++ - " If --bench-input is provided, then the benchmark is run as well."))) + " If --bench-input is provided, then the benchmark is run as well."))) <|> + (Library <$> toVar <$> strOption (long "lib" <> metavar "FUN" <> help ("Compile as a library with its entry point given."))) -- use C as the default backend backendParser :: Parser Backend @@ -210,7 +211,7 @@ data CompileState a = CompileState -- | Compiler entrypoint, given a full configuration and a list of -- files to process, do the thing. compile :: Config -> FilePath -> IO () -compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do +compile config@Config{input,verbosity} fp0 = do -- set the env var DEBUG, to verbosity, when > 1 setDebugEnvVar verbosity @@ -219,6 +220,11 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do let fp1 = dir fp0 -- Parse the input file ((l0, cnt0), fp) <- parseInput config input fp1 + compileFromL0 config cnt0 fp l0 + + +compileFromL0 :: Config -> Int -> FilePath -> L0.Prog0 -> IO () +compileFromL0 config@Config{mode,backend,cfile} cnt0 fp l0 = do let config' = config { srcFile = Just fp } let initTypeChecked :: L0.Prog0 @@ -271,8 +277,6 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do str <- case backend of C -> codegenProg config' l4 - - LLVM -> error $ "Cannot execute through the LLVM backend. To build Gibbon with LLVM: " ++ "stack build --flag gibbon:llvm_enabled" @@ -284,7 +288,7 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do writeFile outfile str -- (Stage 3) Code written, now compile if warranted. - when (mode == ToExe || mode == RunExe || isBench mode ) $ do + when (mode == ToExe || mode == RunExe || isBench mode || isLibrary mode) $ do compileAndRunExe config fp >>= putStr return () @@ -423,6 +427,7 @@ compileAndRunExe cfg@Config{backend,arrayInput,benchInput,mode,cfile,exefile} fp _ -> return "" where outfile = getOutfile backend fp cfile exe = getExeFile backend fp exefile + doto = replaceExtension fp ".o" pointer = gopt Opt_Pointer (dynflags cfg) links = if pointer then " -lgc -lm " @@ -432,13 +437,14 @@ compileAndRunExe cfg@Config{backend,arrayInput,benchInput,mode,cfile,exefile} fp lib_dir <- getRTSBuildDir let rts_o_path = lib_dir "gibbon_rts.o" let compile_prog_cmd = compilationCmd backend cfg - ++ " -o " ++ exe + ++ (if isLibrary mode then (" -c -o " ++ doto) else (" -o " ++ exe)) ++" -I" ++ lib_dir ++" -L" ++ lib_dir ++ " -Wl,-rpath=" ++ lib_dir ++ " " ++ outfile ++ " " ++ rts_o_path ++ links ++ " -lgibbon_rts_ng" + putStrLn compile_prog_cmd execCmd Nothing compile_prog_cmd @@ -541,6 +547,10 @@ isBench :: Mode -> Bool isBench (Bench _) = True isBench _ = False +isLibrary :: Mode -> Bool +isLibrary (Library _) = True +isLibrary _ = False + -- | The debug level at which we start to call the interpreter on the program during compilation. interpDbgLevel :: Int interpDbgLevel = 5 diff --git a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs index 12539d86e..c7fb538be 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs @@ -202,7 +202,8 @@ codegenProg cfg prg@(Prog info_tbl sym_tbl funs mtal) = let struct_tys = uniqueDicts $ S.toList $ harvestStructTys prg return ((L.nub $ makeStructs struct_tys) ++ prots ++ [gibTypesEnum, initInfoTable info_tbl, initSymTable sym_tbl] ++ - funs' ++ [main_expr']) + funs' -- ++ [main_expr'] + ) main_expr :: PassM C.Definition main_expr = do diff --git a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs index e32cef7b4..bf2a52548 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs @@ -93,8 +93,8 @@ simplifyL1 p0 = do p0' <- freshNames1 p0 p1 <- markRecFns p0' p2 <- inlineFuns p1 - p3 <- deadFunElim p2 - pure p3 + -- p3 <- deadFunElim p2 + pure p2 -------------------------------------------------------------------------------- diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 44defae28..e4a9ecd68 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} module Gibbon.Pretty - ( Pretty(..), PPStyle(..), HasPretty, render, pprintHsWithEnv, pprender ) where + ( Pretty(..), PPStyle(..), HasPretty, render, pprintHsWithEnv, pprender, pprenderWithStyle ) where import Prelude hiding ((<>)) import Text.PrettyPrint @@ -41,6 +41,9 @@ class Pretty e where pprender :: Pretty e => e -> String pprender = render . pprint +pprenderWithStyle :: Pretty e => PPStyle -> e -> String +pprenderWithStyle sty e = render $ pprintWithStyle sty e + doublecolon :: Doc doublecolon = colon <> colon diff --git a/gibbon-ghc-integration/cabal.project b/gibbon-ghc-integration/cabal.project index 8fcc1ac92..dec0f3136 100644 --- a/gibbon-ghc-integration/cabal.project +++ b/gibbon-ghc-integration/cabal.project @@ -1,6 +1,7 @@ packages: ../gibbon-compiler plugin0 plugin1 + gibbon-plugin examples with-compiler: ghc-9.4.3 diff --git a/gibbon-ghc-integration/examples/app/Main.hs b/gibbon-ghc-integration/examples/app/Main.hs index bbb255a01..8f33daeb6 100644 --- a/gibbon-ghc-integration/examples/app/Main.hs +++ b/gibbon-ghc-integration/examples/app/Main.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE BangPatterns #-} + module Main ( main ) where import BinTree -- ( fast_print_double, fast_print_double2 ) +import Measure +import Control.Exception import Data.Binary import Data.ByteString.Lazy ( unpack ) import Data.Word @@ -33,10 +37,27 @@ instance Binary Exp where main :: IO () main = do +{- let expr = OpE (IntE 10) (IntE 11) print (unpack (encode expr)) - let tr = Node 10 (Leaf 10 10) (Leaf 20 20) :: Tree Int + let tr = Node 10 (Leaf 10) (Leaf 20) print (unpack (encode tr)) +-} +{- _ <- fast_print_double 3.0 _ <- fast_print_double2 10.0 +-} + + -- !n <- evaluate $ bench1 10 + -- print n + -- !fastn <- fastbench1 10 + -- print fastn + + let size = 22 + let iters = 9 + (res0, t0, t_all) <- bench bench1 size iters + return (show res0, show t0, show t_all) + + (res0, t0, t_all) <- bench fastbench1 size iters + return (show res0, show t0, show t_all) pure () diff --git a/gibbon-ghc-integration/examples/app/Measure.hs b/gibbon-ghc-integration/examples/app/Measure.hs new file mode 100644 index 000000000..de5c0bbe1 --- /dev/null +++ b/gibbon-ghc-integration/examples/app/Measure.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns #-} + +module Measure where + +import Control.Exception (evaluate) +-- import Control.Monad.Par hiding (runParIO) +-- import Control.Monad.Par.IO +import Control.DeepSeq +import Data.Int +import Data.List +import System.Mem (performMajorGC) +import Data.Time.Clock (getCurrentTime, diffUTCTime) + +-------------------------------------------------------------------------------- + +median :: [Double] -> Double +median ls = (sort ls) !! (length ls `div` 2) + +-------------------------------------------------------------------------------- + + +-- benchPar :: (NFData a, NFData b) => +-- (a -> Int64 -> Par b) -> a -> Int64 -> Int64 -> IO (b, Double, Double) +-- benchPar f arg iters cutoff = do +-- let !arg2 = force arg +-- tups <- mapM (\_ -> dotrialPar f arg2 cutoff) [1..iters] +-- let (results, times) = unzip tups +-- -- print times +-- let selftimed = median times +-- batchtime = sum times +-- return $! (last results, selftimed, batchtime) + +-- benchParIO :: (NFData a, NFData b) => +-- (a -> Int64 -> ParIO b) -> a -> Int64 -> Int64 -> IO (b, Double, Double) +-- benchParIO f arg iters cutoff = do +-- let !arg2 = force arg +-- tups <- mapM (\_ -> dotrialParIO f arg2 cutoff) [1..iters] +-- let (results, times) = unzip tups +-- -- print times +-- let selftimed = median times +-- batchtime = sum times +-- return $! (last results, selftimed, batchtime) + +benchIO :: (NFData a, NFData b) => + (a -> IO b) -> a -> Int64 -> IO (b, Double, Double) +benchIO f arg iters = do + let !arg2 = force arg + tups <- mapM (\_ -> dotrialIO f arg2) [1..iters] + let (results, times) = unzip tups + -- print times + let selftimed = median times + batchtime = sum times + return $! (last results, selftimed, batchtime) + + +-- dotrialPar :: (NFData a, NFData b) => +-- (a -> Int64 -> Par b) -> a -> Int64 -> IO (b, Double) +-- dotrialPar f arg cutoff = do +-- performMajorGC +-- t1 <- getCurrentTime +-- !a <- evaluate$ runPar $ (f arg cutoff) +-- t2 <- getCurrentTime +-- let delt = fromRational (toRational (diffUTCTime t2 t1)) +-- putStrLn ("iter time: " ++ show delt) +-- return $! (a,delt) + +-- dotrialParIO :: (NFData a, NFData b) => +-- (a -> Int64 -> ParIO b) -> a -> Int64 -> IO (b, Double) +-- dotrialParIO f arg cutoff = do +-- performMajorGC +-- t1 <- getCurrentTime +-- !a <- runParIO $ (f arg cutoff) +-- t2 <- getCurrentTime +-- let delt = fromRational (toRational (diffUTCTime t2 t1)) +-- putStrLn ("iter time: " ++ show delt) +-- return $! (a,delt) + +dotrialIO :: (NFData a, NFData b) => + (a -> IO b) -> a -> IO (b, Double) +dotrialIO f arg = do + performMajorGC + t1 <- getCurrentTime + !a <- (f arg) + t2 <- getCurrentTime + let delt = fromRational (toRational (diffUTCTime t2 t1)) + putStrLn ("iter time: " ++ show delt) + return $! (a,delt) + +-------------------------------------------------------------------------------- + +bench :: (NFData a, Show b, NFData b) => (a -> b) -> a -> Int64 -> IO (b, Double, Double) +bench f arg iters = do + let !arg2 = force arg + !tups <- mapM (\_ -> dotrial f arg2) [1..iters] + let (results, times) = unzip tups + let selftimed = median times + batchtime = sum times + return $! (last results, selftimed, batchtime) + +dotrial :: (NFData a, Show b, NFData b) => (a -> b) -> a -> IO (b, Double) +dotrial f arg = do + performMajorGC + t1 <- getCurrentTime + !a <- evaluate $ (f arg) + t2 <- getCurrentTime + let delt = fromRational (toRational (diffUTCTime t2 t1)) + putStrLn ("iter time: " ++ show delt) + return $! (a,delt) diff --git a/gibbon-ghc-integration/examples/gibbon-examples.cabal b/gibbon-ghc-integration/examples/gibbon-examples.cabal index 8264e44aa..41d25219c 100644 --- a/gibbon-ghc-integration/examples/gibbon-examples.cabal +++ b/gibbon-ghc-integration/examples/gibbon-examples.cabal @@ -8,34 +8,48 @@ library hs-source-dirs: src exposed-modules: BinTree build-depends: base == 4.17.* - , plugin0 - , plugin1 + -- , plugin0 + -- , plugin1 , inline-c , binary + , gibbon-plugin ghc-options: -Wall -Wcompat -fdefer-typed-holes default-language: Haskell2010 ghc-options: -Wall -Wcompat - -fplugin=Gibbon.Plugin0 - -fplugin=Gibbon.Plugin1 + -O2 + -- -fplugin=Gibbon.Plugin0 + -- -fplugin=Gibbon.Plugin1 + -fplugin=Gibbon.Plugin - "-optl-Wl,--allow-multiple-definition" + -- "-optl-Wl,--allow-multiple-definition" -- "-optl-Wl,--whole-archive" - -- "-optl-Wl,-Bstatic" - -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-ghc-integration/plugin1/cbits/" - -- "-optl-Wl,-ltest2" - -- "-optl-Wl,-Bdynamic" + -- -- "-optl-Wl,-Bstatic" + -- -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-ghc-integration/plugin1/cbits/" + -- -- "-optl-Wl,-ltest2" + -- "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + -- "-optl-Wl,-lgibbon_rts_ng" + -- -- "-optl-Wl,-Bdynamic" + -- -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" -- "-optl-Wl,--no-whole-archive" -dcore-lint -ddump-simpl -dsuppress-all -ddump-to-file + include-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + extra-lib-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + extra-libraries: gibbon_rts_ng + executable run-gibbon-examples hs-source-dirs: app default-language: Haskell2010 main-is: Main.hs - build-depends: base, gibbon-examples, binary, bytestring - ghc-options: - -- "-with-rtsopts=-T" - -- "-with-rtsopts=-s" - -dcore-lint \ No newline at end of file + build-depends: base, gibbon-examples, binary, bytestring, deepseq, time + ghc-options: -O2 + -dcore-lint + include-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + extra-lib-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + extra-libraries: gibbon_rts_ng + -- ghc-options: "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" diff --git a/gibbon-ghc-integration/examples/src/BinTree.hs b/gibbon-ghc-integration/examples/src/BinTree.hs index 5f2503dc5..9d209b6ab 100644 --- a/gibbon-ghc-integration/examples/src/BinTree.hs +++ b/gibbon-ghc-integration/examples/src/BinTree.hs @@ -4,7 +4,8 @@ module BinTree where -import Gibbon.Plugin0 ( PackedAnn(..) ) +-- import Gibbon.Plugin0 ( PackedAnn(..) ) +import Gibbon.Plugin ( liftPacked, Packed, PackedAnn(..) ) import Foreign import Foreign.C.Types import GHC.Generics @@ -14,48 +15,63 @@ import qualified Language.C.Inline as C -------------------------------------------------------------------------------- -data Tree a = Leaf Int a - | Node Int (Tree a) (Tree a) +data Tree = Leaf Int + | Node Int Tree Tree deriving (Generic) -instance Binary a => Binary (Tree a) +instance Binary Tree -{-# ANN mkTree_seq LiftPacked #-} -mkTree_seq :: Int -> Tree Bool +-- {-# ANN mkTree_seq LiftPacked #-} +mkTree_seq :: Int -> Tree mkTree_seq i = if i <= 0 - then Leaf 1 True + then Leaf 1 else let x = mkTree_seq (i-1) y = mkTree_seq (i-1) in Node i x y -{-# ANN sumTree_seq LiftPacked #-} -sumTree_seq :: Tree a -> Int -sumTree_seq foo = - case foo of - Leaf i _ -> i +-- {-# ANN sumTree_seq LiftPacked #-} +sumTree_seq :: Tree -> Int +sumTree_seq tr = + case tr of + Leaf i -> i Node _ a b -> let x = sumTree_seq a y = sumTree_seq b in x + y -{-# ANN bench1 LiftPacked #-} bench1 :: Int -> Int bench1 n = sumTree_seq (mkTree_seq n) +{-# ANN liftbench1 LiftPacked #-} +liftbench1 :: Int -> Int +liftbench1 n = sumTree_seq (mkTree_seq n) + + +foreign import ccall unsafe "c_liftbench1" + cfastbench1 :: CInt -> CInt + +fastbench1 :: Int -> Int +fastbench1 x = + let y = cfastbench1 (fromIntegral x) + in fromIntegral y + -------------------------------------------------------------------------------- -foreign import ccall "print_double" - c_print_double :: CDouble -> IO CInt +-- foreign import ccall "print_double" +-- c_print_double :: CDouble -> IO CInt -fast_print_double :: Double -> IO Int -fast_print_double x = do - y <- c_print_double (realToFrac x) - pure $ fromIntegral y +-- fast_print_double :: Double -> IO Int +-- fast_print_double x = do +-- y <- c_print_double (realToFrac x) +-- pure $ fromIntegral y -------------------------------------------------------------------------------- + +{- + C.include "" C.include "" C.include "" @@ -67,5 +83,7 @@ foreign import ccall "print_double2" fast_print_double2 :: Double -> IO Int fast_print_double2 x = do - y <- c_print_double2 (realToFrac x) - pure $ fromIntegral y + y <- c_print_double2 (realToFrac x) + pure $ fromIntegral y + +-} diff --git a/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal b/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal new file mode 100644 index 000000000..88d29e686 --- /dev/null +++ b/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal @@ -0,0 +1,21 @@ +cabal-version: >= 1.10 +name: gibbon-plugin +version: 0.1 +author: Chaitanya Koparkar +maintainer: ckoparkar@gmail.com +build-type: Simple + +library + exposed-modules: Gibbon.Plugin + hs-source-dirs: src + build-depends: base == 4.17.* + , ghc == 9.4.3 + , gibbon + , containers + , filepath + , random + ghc-options: -Wall -Wcompat -fdefer-typed-holes + default-language: Haskell2010 + default-extensions: ScopedTypeVariables + BangPatterns + TupleSections diff --git a/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs new file mode 100644 index 000000000..f46a5de92 --- /dev/null +++ b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Gibbon.Plugin where + +import qualified GHC.Types.TyThing as GHC +import qualified GHC.Unit.External as GHC +import qualified GHC.Utils.Trace as GHC +import qualified GHC.Plugins as GHC +import qualified GHC.Utils.Outputable as Ppr +import qualified GHC.Types.Var.Set as GHC +import qualified GHC.Core.Multiplicity as GHC +import qualified GHC.Core.TyCo.Rep as GHC + + +import Data.Foldable +import Foreign.Ptr ( Ptr ) +import Data.Data ( Data ) +import qualified Data.Set as Set +import qualified Data.Map as M +import System.FilePath +import System.Random +import Data.Word +import Data.List + +import qualified Gibbon.Common as Gib +import qualified Gibbon.Pretty as Gib +import qualified Gibbon.L0.Syntax as Gib +import qualified Gibbon.Compiler as Gib +import qualified Gibbon.DynFlags as Gib + + +-------------------------------------------------------------------------------- + +data Packed a = Packed (Ptr a) + deriving Show + +{-# NOINLINE liftPacked #-} +liftPacked :: (a -> b) -> Packed a -> Packed b +liftPacked = error "liftPacked" + +type PackedAnnEnv = GHC.NameEnv PackedAnn + +data PackedAnn = LiftPacked + deriving Data + +instance Ppr.Outputable PackedAnn where + ppr LiftPacked = Ppr.text "LiftPacked" + + +-------------------------------------------------------------------------------- + + +plugin :: GHC.Plugin +plugin = GHC.defaultPlugin { GHC.installCoreToDos = installGibbonPlugin + -- , GHC.pluginRecompile = GHC.purePlugin + } + where + installGibbonPlugin :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo] + installGibbonPlugin _ todos = return (gibbonCoreTodo : todos) + + gibbonCoreTodo :: GHC.CoreToDo + gibbonCoreTodo = GHC.CoreDoPluginPass "GibbonLiftPacked" gibbonPlugin + + +gibbonPlugin :: GHC.ModGuts -> GHC.CoreM GHC.ModGuts +gibbonPlugin mod_guts = do + GHC.liftIO $ print "[Gibbon Core Plugin (final)] Starting..." + + -- -- (0) + -- GHC.putMsg (Ppr.text "\nInput module:\n----------------------------------------" Ppr.$$ (GHC.ppr (GHC.mg_binds mod_guts))) + + -- (1) and (2): Find all arguments to liftPacked, form an initial root set, and then fetch the transitive closure. + (to_lift, dcons, closure) <- transitiveClosure mod_guts + GHC.putMsg (Ppr.text "\nExpressions to lift:\n----------------------------------------" Ppr.$$ (GHC.ppr (to_lift, closure))) + + closure' <- mapM (\(f,rhs) -> + if elem f to_lift + then do + let name = GHC.idName f + uniq <- GHC.getUniqueM + let name' = GHC.mkFCallName uniq ("c_" ++ nameToString name) + pure (GHC.setIdName f name',rhs) + else pure (f,rhs)) + closure + + -- (3) Translate the closure to Gibbon L0. + l0_prog <- coreToL0 dcons closure' + GHC.liftIO $ putStrLn "\nL0 program:\n----------------------------------------" + GHC.liftIO $ putStrLn (Gib.pprender l0_prog) + + -- (4) Have Gibbon generate a .o file. + fp <- GHC.liftIO $ generateObjectFile l0_prog + GHC.liftIO $ putStrLn "\nCompiled:\n----------------------------------------" + GHC.liftIO $ putStrLn fp + + -- (5) Link the .o file in the module. + let objfile = replaceExtension fp ".o" + let rtsfile = "/home/ckoparka/chai/tree-velocity/gibbon-rts/build/gibbon_rts.o" + let mod_guts' = mod_guts { GHC.mg_foreign_files = (GHC.mg_foreign_files mod_guts) + ++ [ ( GHC.RawObject, objfile) + , ( GHC.RawObject, rtsfile) + ] + } + + -- fficalls <- foldrM (\(f,rhs) acc -> + -- if elem f to_lift + -- then do + -- let name = GHC.idName f + -- uniq <- GHC.getUniqueM + -- let name' = GHC.mkFCallName uniq ("c_" ++ nameToString name) + -- let f' = GHC.setIdName f name' + -- uniq2 <- GHC.getUniqueM + -- let name'' = GHC.mkFCallName uniq ("fast_" ++ nameToString name) + -- let f'' = GHC.setIdName f name'' + -- -- case rhs of + -- -- GHC.Lam w bod -> + -- -- GHC.Lam w (GHC.mkCoreApps f'' ) + -- else pure acc) + -- [] + -- closure + -- GHC.putMsg (Ppr.text "\nFFI calls:\n----------------------------------------" Ppr.$$ (GHC.ppr (fficalls))) + + -- (6) Replace (liftPacked f) with a FFI function call to gibbon_f. + + return mod_guts' + + +-------------------------------------------------------------------------------- + +generateObjectFile :: Gib.Prog0 -> IO FilePath +generateObjectFile l0 = do + let config = Gib.defaultConfig { Gib.mode = Gib.Library (Gib.toVar "xxx") } + let dflags' = Gib.gopt_set Gib.Opt_DisableGC $ Gib.gopt_set Gib.Opt_Packed (Gib.dynflags config) + let config' = config { Gib.dynflags = dflags', Gib.optc = " -O3 " } + uniq <- randomIO :: IO Word16 + let fp = "/home/ckoparka/chai/gibbon-ghc-integration-files/" ++ show uniq ++ ".hs" + Gib.compileFromL0 config' 0 fp l0 + return fp + +-------------------------------------------------------------------------------- + +transitiveClosure :: GHC.ModGuts -> GHC.CoreM ([GHC.Id], [GHC.DataCon], [(GHC.Var, GHC.CoreExpr)]) +transitiveClosure mod_guts = do + -- Things defined in other modules and libraries. + hsc_env <- GHC.getHscEnv + external_package_state <- GHC.liftIO $ GHC.hscEPS hsc_env + let external_ids = GHC.nonDetNameEnvElts (GHC.eps_PTE external_package_state) + external_unfoldings = + foldr (\tyt acc -> + case tyt of + GHC.AnId i -> case GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding i) of + Nothing -> acc + Just expr -> GHC.extendVarEnv acc i expr + _ -> acc) + GHC.emptyVarEnv + external_ids + + -- Things defined in this module. + let (_module_binds_ls,module_binds,module_ids) = + foldr (\b (acc1,acc2,acc3) -> case b of + GHC.NonRec i rhs -> ((i,rhs):acc1,GHC.extendVarEnv acc2 i rhs, i:acc3) + GHC.Rec ls -> foldr (\(i,rhs) (acc4,acc5,acc6) -> + ((i,rhs):acc4,GHC.extendVarEnv acc5 i rhs, i:acc6)) + (acc1,acc2,acc3) + ls) + ([],GHC.emptyVarEnv,[]) + (GHC.mg_binds mod_guts) + + -- Get Ids that are given a 'LiftPacked' pragma. + (_, packed_annots :: PackedAnnEnv) <- GHC.getFirstAnnotations GHC.deserializeWithData mod_guts + let to_lift = filter (\v -> GHC.elemNameEnv (GHC.idName v) packed_annots) module_ids + + -- Given a list of Ids, suck in their transitive closure. + let fixpoint dcons_ls binds_ls sucked_in todo + -- No more Ids to process. + | [] <- todo + = (dcons_ls, binds_ls) + -- This Id is already sucked in or is meant to be excluded. + | (x:xs) <- todo + , GHC.elemDVarSet x sucked_in || + varToString x `Set.member` excludedFromClos + = fixpoint dcons_ls binds_ls sucked_in xs + -- Data constructor. + | (x:xs) <- todo + , Just dcon <- GHC.isDataConId_maybe x + = fixpoint (dcon:dcons_ls) binds_ls sucked_in xs + -- Value binding. + | (x:xs) <- todo + = if elem x module_ids + then let rhs = GHC.lookupVarEnv_NF module_binds x + binds_ls1 = (x,rhs):binds_ls + sucked_in1 = GHC.extendDVarSet sucked_in x + xs1 = (GHC.exprSomeFreeVarsList GHC.isId rhs) ++ xs + in -- GHC.pprTrace "(1):" (GHC.ppr (x, rhs, GHC.exprSomeFreeVarsList GHC.isId rhs)) + (fixpoint dcons_ls binds_ls1 sucked_in1 xs1) + else case GHC.lookupVarEnv external_unfoldings x of + Nothing -> + -- GHC.pprSorry ("No unfolding available for:") (GHC.ppr x) + GHC.pprTrace "WARNING:" (GHC.ppr (Ppr.text "No unfolding available for:" Ppr.<> GHC.ppr x)) + (fixpoint dcons_ls binds_ls sucked_in xs) + Just rhs -> + let binds_ls1 = (x,rhs):binds_ls + sucked_in1 = GHC.extendDVarSet sucked_in x + xs1 = (GHC.exprSomeFreeVarsList GHC.isId rhs) ++ xs + in -- GHC.pprTrace "(2):" (GHC.ppr (x,rhs,GHC.exprSomeFreeVarsList GHC.isId rhs)) + fixpoint dcons_ls binds_ls1 sucked_in1 xs1 + + -- The main thing. + let (dcons, binds) = fixpoint [] [] GHC.emptyDVarSet to_lift + + pure (to_lift, dcons, binds) + + +-- Things that are not included in the transitive closure. +excludedFromClos :: Set.Set String +excludedFromClos = Set.fromList $ + [ "I#" ] ++ + [ "$fOrdInt", "compareInt", "ltInt", "leInt", "gtInt", "geInt", "$fOrdInt_$cmax", "$fOrdInt_$cmin", "$fOrdInt_$c<="] ++ + [ "$fEqInt", "eqInt", "neInt" ] ++ + [ "$fNumInt", "$fNumInt_$c+", "$fNumInt_$c-", "$fNumInt_$c*", + "$fNumInt_$cnegate", "$fNumInt_$cabs", "$fNumInt_$csignum", + "$fNumInt_$cfromInteger" ] ++ + [ "-", "<=", "+" ] + +{- + +findLP :: GHC.CoreBind -> [GHC.CoreExpr] +findLP bind = gorec bind [] + where + gorec bind acc = case bind of + GHC.NonRec _ bod -> go bod [] + GHC.Rec ls -> foldr (\(_,rhs) acc -> go rhs acc) [] ls + + go expr acc = case expr of + GHC.Var v -> acc + GHC.Lit _lit -> acc + GHC.App f arg -> case f of + -- GHC.Var v -> if isLP v + -- then f : arg : acc + -- else go arg (go f acc) + GHC.App g@(GHC.App f arg) arg2 -> case f of + GHC.Var v -> if isLP v + then f : g : arg : arg2 : acc + else go arg (go f acc) + _ -> go arg (go f acc) + _ -> go arg (go f acc) + GHC.Lam _ bod -> go bod acc + GHC.Let bind rhs -> go rhs (gorec bind acc) + GHC.Case scrt _ _ alts -> + foldr (\(GHC.Alt _ _ rhs) acc1 -> go rhs acc1) (go scrt acc) alts + GHC.Cast rhs _ -> go rhs acc + _ -> acc + + + isLP v = GHC.nameOccName (GHC.varName v) == (GHC.mkVarOcc "liftPacked") +-} + + +-------------------------------------------------------------------------------- + +coreToL0 :: [GHC.DataCon] -> [(GHC.Id, GHC.CoreExpr)] -> GHC.CoreM Gib.Prog0 +coreToL0 dcons funs = do + let ddefs = convertDcons dcons + funs' <- mapM convertFun funs + let fundefs = M.fromList $ map (\f -> (Gib.funName f, f)) funs' + pure $ Gib.Prog { Gib.ddefs = ddefs + , Gib.fundefs = fundefs + , Gib.mainExp = Nothing + } + +convertFun :: (GHC.Id, GHC.CoreExpr) -> GHC.CoreM Gib.FunDef0 +convertFun (toplvl,bod0) = + case bod0 of + GHC.Lam arg bod -> do + bod' <- go bod + pure $ Gib.FunDef (Gib.toVar (nameToString (GHC.idName toplvl))) + [(Gib.toVar (varToString arg))] + (Gib.ForAll [] (ghcTyToGibTy (GHC.idType toplvl))) + bod' + (Gib.FunMeta Gib.Rec Gib.NoInline False) + where + go expr = + case expr of + GHC.Var v -> pure $ Gib.VarE $ Gib.toVar (varToString v) + GHC.Case scrt v ty alts -> do + let makeif = let (GHC.Alt dcon0 _ _) = head alts in + case dcon0 of + GHC.DataAlt dcon -> + let name = nameToString (GHC.dataConName dcon) in + name == "True" || name == "False" + if makeif + then do + let [(GHC.Alt _ _ false_expr)] = filter (\(GHC.Alt (GHC.DataAlt dcon) _ _) -> nameToString (GHC.dataConName dcon) == "False") alts + let [(GHC.Alt _ _ true_expr)] = filter (\(GHC.Alt (GHC.DataAlt dcon) _ _) -> nameToString (GHC.dataConName dcon) == "True") alts + scrt' <- go scrt + true_expr' <- go true_expr + false_expr' <- go false_expr + pure $ Gib.IfE scrt' true_expr' false_expr' + else do + scrt' <- go scrt + alts' <- mapM (\(GHC.Alt (GHC.DataAlt dcon) vars rhs) -> do + let dcon' = nameToString (GHC.dataConName dcon) + let vars' = map (\v -> (Gib.toVar (nameToString (GHC.idName v)), ghcTyToGibTy (GHC.idType v))) vars + rhs' <- go rhs + pure (dcon', vars', rhs')) + alts + pure $ Gib.CaseE scrt' alts' + GHC.App _ _ -> do + let (f:args) = uncurryApp expr + -- GHC.putMsg (Ppr.text "\nUncurried;\n----------------------------------------" Ppr.$$ (GHC.ppr (f,args))) + case f of + GHC.Var fx -> do + case GHC.isDataConWorkId_maybe fx of + Nothing -> do + case (varToString fx) of + "-" -> do + -- args' <- mapM go args + let x = args !! 2 + let y = args !! 3 + x' <- go x + y' <- go y + pure $ Gib.PrimAppE Gib.SubP [x',y'] + "+" -> do + -- args' <- mapM go args + let x = args !! 2 + let y = args !! 3 + x' <- go x + y' <- go y + pure $ Gib.PrimAppE Gib.AddP [x',y'] + "<=" -> do + -- args' <- mapM go args + let x = args !! 2 + let y = args !! 3 + x' <- go x + y' <- go y + pure $ Gib.PrimAppE Gib.LtEqP [x',y'] + _ -> do + args' <- mapM go args + pure $ Gib.AppE (Gib.toVar (varToString fx)) [] args' + + Just dcon -> + case nameToString (GHC.dataConName dcon) of + "I#" -> case head args of + GHC.Lit lit -> case lit of + GHC.LitNumber _ i -> pure $ Gib.LitE (fromIntegral i) + _ -> error "unexpected" + _ -> do + args' <- mapM go args + pure $ Gib.DataConE (Gib.ProdTy []) (nameToString (GHC.dataConName dcon)) args' + _ -> + error "unexpected" + -- pure $ Gib.AppE (Gib.toVar "todo4") [] [] + +{- + arg' <- go arg + case f of + GHC.Var x -> + case GHC.isDataConWorkId_maybe x of + Nothing -> pure $ Gib.AppE (Gib.toVar (varToString x)) [] [arg'] + Just dcon -> if nameToString (GHC.dataConName dcon) == "I#" + then case arg of + GHC.Lit lit -> case lit of + GHC.LitNumber _ i -> pure $ Gib.LitE (fromIntegral i) + _ -> error "unexpected" + else do + pure $ Gib.DataConE (Gib.ProdTy []) (nameToString (GHC.dataConName dcon)) [arg'] + _ -> do + let (g,args) = uncurryApp expr + case g of + GHC.putMsg (Ppr.text "\nUncurried;\n----------------------------------------" Ppr.$$ (GHC.ppr xs)) + pure $ Gib.AppE (Gib.toVar "todo3") [] [arg'] +-} + GHC.Lam var bod -> do + bod' <- go bod + pure $ Gib.Ext (Gib.LambdaE [(Gib.toVar (varToString var), ghcTyToGibTy (GHC.varType var))] bod') + _ -> do + -- GHC.putMsg (Ppr.text "\nExpr;\n----------------------------------------" Ppr.$$ (GHC.ppr expr)) + -- pure (Gib.LitE 20) + error "todo" + +uncurryApp :: GHC.CoreExpr -> [GHC.CoreExpr] +uncurryApp = go [] + where + go acc e = + case e of + GHC.App f arg -> + go (arg : acc) f + _ -> e : acc + +convertDcons :: [GHC.DataCon] -> Gib.DDefs0 +convertDcons dcons = + foldr go M.empty dcons + where + go :: GHC.DataCon -> Gib.DDefs0 -> Gib.DDefs0 + go dcon ddefs + | GHC.isVanillaDataCon dcon + , tycon <- GHC.dataConTyCon dcon + , GHC.isVanillaAlgTyCon tycon + , tyname <- GHC.tyConName tycon + , tyname_str <- nameToString tyname + , tyname_var <- Gib.toVar tyname_str + = case tyname_str of + "Int" -> ddefs + "Float" -> ddefs + "Bool" -> ddefs + _ -> let tyvars = GHC.tyConTyVars tycon + tyvars_var = map (Gib.UserTv . Gib.toVar . varToString) tyvars + dcname = GHC.dataConName dcon + (_,_,_,_,dcon_args,_dcon_res) = GHC.dataConFullSig dcon + dcon_tys = map (\ty -> (False,ghcScaledTyToGibTy ty)) dcon_args + dcon_gib = (nameToString dcname, dcon_tys) + in case M.lookup tyname_var ddefs of + Nothing -> + let ddef = Gib.DDef tyname_var tyvars_var [dcon_gib] + in M.insert tyname_var ddef ddefs + Just ddef -> + let ddef' = ddef { Gib.dataCons = dcon_gib : (Gib.dataCons ddef) } + in M.insert tyname_var ddef' ddefs + + + | tycon <- GHC.dataConTyCon dcon + = GHC.sorryDoc ("Non-vanilla datacons not supported yet:") (GHC.ppr (dcon,tycon)) + + +ghcScaledTyToGibTy :: GHC.Scaled GHC.Type -> Gib.Ty0 +ghcScaledTyToGibTy (GHC.Scaled _ ty) = ghcTyToGibTy ty + +ghcTyToGibTy :: GHC.Type -> Gib.Ty0 +ghcTyToGibTy ty + | GHC.AppTy{} <- ty + = let (arg_tys,res_ty) = GHC.splitPiTys ty + in GHC.sorryDoc "todo(1):" (GHC.ppr (arg_tys,res_ty)) + + | GHC.ForAllTy{} <- ty + = GHC.sorryDoc "todo(2):" (GHC.ppr ty) + + | GHC.TyConApp tycon tyargs <- ty + = if not (length tyargs == GHC.tyConArity tycon) + then GHC.sorryDoc "unsaturated TyConApp:" (GHC.ppr ty) + else let tyname_str = nameToString (GHC.tyConName tycon) in + case tyname_str of + "Int" -> Gib.IntTy + "Float" -> Gib.FloatTy + "Bool" -> Gib.BoolTy + _oth -> let tyvars = GHC.tyConTyVars tycon + tyvars_var = map (Gib.TyVar . Gib.UserTv . Gib.toVar . varToString) tyvars + in Gib.PackedTy tyname_str tyvars_var + -- GHC.sorryDoc "todo(3):" (GHC.ppr ty) + + | GHC.TyVarTy v <- ty + = Gib.TyVar (Gib.UserTv (Gib.toVar (varToString v))) + + | GHC.FunTy _ _ arg res <- ty + = Gib.ArrowTy [ghcTyToGibTy arg] (ghcTyToGibTy res) + + | otherwise + = GHC.sorryDoc "todo(4):" (GHC.ppr ty) + + +-------------------------------------------------------------------------------- + +varToString :: GHC.Var -> String +varToString = nameToString . GHC.varName + +nameToString :: GHC.Name -> String +nameToString = GHC.occNameString . GHC.nameOccName diff --git a/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs b/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs index 4850b4770..cd1870662 100644 --- a/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs +++ b/gibbon-ghc-integration/plugin0/src/Gibbon/Plugin0.hs @@ -8,8 +8,14 @@ import qualified GHC.Utils.Trace as GHC import qualified GHC.Plugins as GHC import qualified GHC.Utils.Outputable as Ppr import qualified GHC.Types.Var.Set as GHC +import qualified GHC.Plugins as GHC +import qualified GHC.Core.Multiplicity as GHC +import qualified GHC.Core.TyCo.Rep as GHC + + import Data.Data ( Data ) import qualified Data.Set as Set +import qualified Data.Map as M import Gibbon.CoreToL0 ( coreToL0 ) import Gibbon.Utils diff --git a/gibbon-rts/Makefile b/gibbon-rts/Makefile index 75ee35aff..1b66ac2c6 100644 --- a/gibbon-rts/Makefile +++ b/gibbon-rts/Makefile @@ -28,7 +28,7 @@ CC := gcc AR := gcc-ar -CFLAGS := -Wall -Wextra -Wpedantic -Wshadow -Werror -std=gnu11 -flto +CFLAGS := -Wall -Wextra -Wpedantic -Wshadow -Werror -std=gnu11 # -flto RSC := cargo RSFLAGS := -v VERBOSITY := 1 diff --git a/gibbon-rts/rts-c/gibbon_rts.h b/gibbon-rts/rts-c/gibbon_rts.h index 6c9b9914a..48149cf54 100644 --- a/gibbon-rts/rts-c/gibbon_rts.h +++ b/gibbon-rts/rts-c/gibbon_rts.h @@ -747,11 +747,11 @@ INLINE_HEADER void gib_grow_region(char **writeloc_addr, char **footer_addr) bool old_chunk_in_nursery; GibOldgenChunkFooter *old_footer = NULL; - if (gib_addr_in_nursery(footer_ptr)) { - old_chunk_in_nursery = true; - GibNurseryChunkFooter oldsize = *(GibNurseryChunkFooter *) footer_ptr; - newsize = oldsize * 2; - } else { + // if (gib_addr_in_nursery(footer_ptr)) { + // old_chunk_in_nursery = true; + // GibNurseryChunkFooter oldsize = *(GibNurseryChunkFooter *) footer_ptr; + // newsize = oldsize * 2; + // } else { old_chunk_in_nursery = false; old_footer = (GibOldgenChunkFooter *) footer_ptr; newsize = sizeof(GibOldgenChunkFooter) + (old_footer->size); @@ -759,7 +759,7 @@ INLINE_HEADER void gib_grow_region(char **writeloc_addr, char **footer_addr) if (newsize > GIB_MAX_CHUNK_SIZE) { newsize = GIB_MAX_CHUNK_SIZE; } - } + // } #if defined _GIBBON_EAGER_PROMOTION && _GIBBON_EAGER_PROMOTION == 0 // If the old chunk is in nursery, try to grow it in the nursery. From f8c689d832b9a9a653c2537cb61a8177e398ce17 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Tue, 2 May 2023 07:46:01 -0400 Subject: [PATCH 3/8] Edits --- gibbon-ghc-integration/examples/app/Main.hs | 11 ++++++----- gibbon-ghc-integration/examples/src/BinTree.hs | 10 +++++----- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/gibbon-ghc-integration/examples/app/Main.hs b/gibbon-ghc-integration/examples/app/Main.hs index 8f33daeb6..306dd62eb 100644 --- a/gibbon-ghc-integration/examples/app/Main.hs +++ b/gibbon-ghc-integration/examples/app/Main.hs @@ -53,11 +53,12 @@ main = do -- !fastn <- fastbench1 10 -- print fastn - let size = 22 + let size = 25 let iters = 9 - (res0, t0, t_all) <- bench bench1 size iters - return (show res0, show t0, show t_all) + (res0, t0, t_all_0) <- bench bench1 size iters - (res0, t0, t_all) <- bench fastbench1 size iters - return (show res0, show t0, show t_all) + (res1, t1, t_all_1) <- benchIO fastbench1 size iters + + print (res0,t0) + print (res1,t1) pure () diff --git a/gibbon-ghc-integration/examples/src/BinTree.hs b/gibbon-ghc-integration/examples/src/BinTree.hs index 9d209b6ab..7bb64f98a 100644 --- a/gibbon-ghc-integration/examples/src/BinTree.hs +++ b/gibbon-ghc-integration/examples/src/BinTree.hs @@ -50,12 +50,12 @@ liftbench1 n = sumTree_seq (mkTree_seq n) foreign import ccall unsafe "c_liftbench1" - cfastbench1 :: CInt -> CInt + cfastbench1 :: CInt -> IO CInt -fastbench1 :: Int -> Int -fastbench1 x = - let y = cfastbench1 (fromIntegral x) - in fromIntegral y +fastbench1 :: Int -> IO Int +fastbench1 x = do + y <- cfastbench1 (fromIntegral x) + pure $ fromIntegral y -------------------------------------------------------------------------------- From 3c736d07b8147abcd42a5f604ae3e960d580f869 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Tue, 11 Jun 2024 19:06:06 +0000 Subject: [PATCH 4/8] brush up the plugin --- gibbon-ghc-integration/cabal.project | 4 ---- .../examples/gibbon-examples.cabal | 14 +++++--------- .../gibbon-plugin/gibbon-plugin.cabal | 4 ++-- .../gibbon-plugin/src/Gibbon/Plugin.hs | 5 +++-- 4 files changed, 10 insertions(+), 17 deletions(-) diff --git a/gibbon-ghc-integration/cabal.project b/gibbon-ghc-integration/cabal.project index dec0f3136..abce28779 100644 --- a/gibbon-ghc-integration/cabal.project +++ b/gibbon-ghc-integration/cabal.project @@ -1,10 +1,6 @@ packages: ../gibbon-compiler - plugin0 - plugin1 gibbon-plugin examples -with-compiler: ghc-9.4.3 - package * ghc-options: -fexpose-all-unfoldings diff --git a/gibbon-ghc-integration/examples/gibbon-examples.cabal b/gibbon-ghc-integration/examples/gibbon-examples.cabal index 41d25219c..f945ab7c8 100644 --- a/gibbon-ghc-integration/examples/gibbon-examples.cabal +++ b/gibbon-ghc-integration/examples/gibbon-examples.cabal @@ -7,9 +7,7 @@ build-type: Simple library hs-source-dirs: src exposed-modules: BinTree - build-depends: base == 4.17.* - -- , plugin0 - -- , plugin1 + build-depends: base , inline-c , binary , gibbon-plugin @@ -17,8 +15,6 @@ library default-language: Haskell2010 ghc-options: -Wall -Wcompat -O2 - -- -fplugin=Gibbon.Plugin0 - -- -fplugin=Gibbon.Plugin1 -fplugin=Gibbon.Plugin -- "-optl-Wl,--allow-multiple-definition" @@ -36,8 +32,8 @@ library -dcore-lint -ddump-simpl -dsuppress-all -ddump-to-file - include-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - extra-lib-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + include-dirs: "../../gibbon-rts/build" + extra-lib-dirs: "../../gibbon-rts/build" extra-libraries: gibbon_rts_ng @@ -48,8 +44,8 @@ executable run-gibbon-examples build-depends: base, gibbon-examples, binary, bytestring, deepseq, time ghc-options: -O2 -dcore-lint - include-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - extra-lib-dirs: "/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + include-dirs: "../../gibbon-rts/build" + extra-lib-dirs: "../../gibbon-rts/build" extra-libraries: gibbon_rts_ng -- ghc-options: "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" diff --git a/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal b/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal index 88d29e686..0ee50d745 100644 --- a/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal +++ b/gibbon-ghc-integration/gibbon-plugin/gibbon-plugin.cabal @@ -8,8 +8,8 @@ build-type: Simple library exposed-modules: Gibbon.Plugin hs-source-dirs: src - build-depends: base == 4.17.* - , ghc == 9.4.3 + build-depends: base + , ghc , gibbon , containers , filepath diff --git a/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs index f46a5de92..d5dc454aa 100644 --- a/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs +++ b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs @@ -2,6 +2,7 @@ module Gibbon.Plugin where +import Data.String import qualified GHC.Types.TyThing as GHC import qualified GHC.Unit.External as GHC import qualified GHC.Utils.Trace as GHC @@ -78,7 +79,7 @@ gibbonPlugin mod_guts = do then do let name = GHC.idName f uniq <- GHC.getUniqueM - let name' = GHC.mkFCallName uniq ("c_" ++ nameToString name) + let name' = GHC.mkFCallName uniq (fromString $ "c_" ++ nameToString name) pure (GHC.setIdName f name',rhs) else pure (f,rhs)) closure @@ -133,7 +134,7 @@ generateObjectFile l0 = do let dflags' = Gib.gopt_set Gib.Opt_DisableGC $ Gib.gopt_set Gib.Opt_Packed (Gib.dynflags config) let config' = config { Gib.dynflags = dflags', Gib.optc = " -O3 " } uniq <- randomIO :: IO Word16 - let fp = "/home/ckoparka/chai/gibbon-ghc-integration-files/" ++ show uniq ++ ".hs" + let fp = "/tmp/gibbon-ghc-integration-file-" ++ show uniq ++ ".hs" Gib.compileFromL0 config' 0 fp l0 return fp From 2db208c05e7f18e167ce9877fafd62c8c5901854 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Thu, 20 Jun 2024 19:32:39 +0000 Subject: [PATCH 5/8] generate the main expression if not in the library mode --- gibbon-compiler/src/Gibbon/Common.hs | 9 +++++++++ gibbon-compiler/src/Gibbon/Compiler.hs | 9 --------- gibbon-compiler/src/Gibbon/Passes/Codegen.hs | 8 +++++--- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index c5cc1ed14..8ee342af0 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -22,6 +22,7 @@ module Gibbon.Common -- * Gibbon configuration , Config(..), Input(..), Mode(..), Backend(..), defaultConfig , RunConfig(..), getRunConfig, defaultRunConfig, getGibbonConfig + , isBench, isLibrary -- * Misc helpers , SSModality(..), (#), (!!!), fragileZip, fragileZip', sdoc, ndoc, abbrv @@ -255,6 +256,14 @@ data Mode = ToParse -- ^ Parse and then stop | Library Var -- ^ Compile as a library, with its main entry point given. deriving (Show, Read, Eq, Ord) +isBench :: Mode -> Bool +isBench (Bench _) = True +isBench _ = False + +isLibrary :: Mode -> Bool +isLibrary (Library _) = True +isLibrary _ = False + -- | Compilation backend used data Backend = C | LLVM deriving (Show,Read,Eq,Ord) diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 28c0fa532..3ad5c2e56 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -542,15 +542,6 @@ compilationCmd C config = (cc config) ++" -std=gnu11 " simpleWriteBarrier = gopt Opt_SimpleWriteBarrier dflags lazyPromote = gopt Opt_NoEagerPromote dflags --- | -isBench :: Mode -> Bool -isBench (Bench _) = True -isBench _ = False - -isLibrary :: Mode -> Bool -isLibrary (Library _) = True -isLibrary _ = False - -- | The debug level at which we start to call the interpreter on the program during compilation. interpDbgLevel :: Int interpDbgLevel = 5 diff --git a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs index c7fb538be..757213f20 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs @@ -189,7 +189,7 @@ sortFns (Prog _ _ funs mtal) = foldl go S.empty allTails -- | Compile a program to C code that has the side effect of the -- "gibbon_main" expression in that program. codegenProg :: Config -> Prog -> IO String -codegenProg cfg prg@(Prog info_tbl sym_tbl funs mtal) = +codegenProg cfg@Config{mode} prg@(Prog info_tbl sym_tbl funs mtal) = return (hashIncludes ++ pretty 80 (stack (map ppr defs))) where init_fun_env = foldr (\fn acc -> M.insert (funName fn) (map snd (funArgs fn), funRetTy fn) acc) M.empty funs @@ -200,9 +200,11 @@ codegenProg cfg prg@(Prog info_tbl sym_tbl funs mtal) = (prots,funs') <- (unzip . concat) <$> mapM codegenFun funs main_expr' <- main_expr let struct_tys = uniqueDicts $ S.toList $ harvestStructTys prg - return ((L.nub $ makeStructs struct_tys) ++ prots ++ + return ((L.nub $ makeStructs struct_tys) ++ + prots ++ [gibTypesEnum, initInfoTable info_tbl, initSymTable sym_tbl] ++ - funs' -- ++ [main_expr'] + funs' ++ + if isLibrary mode then [] else [main_expr'] ) main_expr :: PassM C.Definition From 1c8b1464208c1d2986f1e326dcfd20227490c19c Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Fri, 21 Jun 2024 01:55:39 +0000 Subject: [PATCH 6/8] FIXME: trying absolute paths in cabal file to find the .so but with no luck at least, the .o is fetched in a reasonable way now this also tries to compile RTS from the plugin, but local experiments doesn't seem to show it having any effect, unfortunately --- gibbon-compiler/src/Gibbon/Compiler.hs | 1 + .../examples/gibbon-examples.cabal | 15 +++++++++------ .../gibbon-plugin/src/Gibbon/Plugin.hs | 16 +++++++++++----- 3 files changed, 21 insertions(+), 11 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 3ad5c2e56..6df15193f 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -15,6 +15,7 @@ module Gibbon.Compiler , configParser, configWithArgs, defaultConfig -- * Some other helper fns , compileAndRunExe + , getRTSBuildDir, compileRTS ) where diff --git a/gibbon-ghc-integration/examples/gibbon-examples.cabal b/gibbon-ghc-integration/examples/gibbon-examples.cabal index f945ab7c8..94fcc7cb0 100644 --- a/gibbon-ghc-integration/examples/gibbon-examples.cabal +++ b/gibbon-ghc-integration/examples/gibbon-examples.cabal @@ -32,9 +32,10 @@ library -dcore-lint -ddump-simpl -dsuppress-all -ddump-to-file - include-dirs: "../../gibbon-rts/build" - extra-lib-dirs: "../../gibbon-rts/build" + -- include-dirs: "../../gibbon-rts/build" + -- extra-lib-dirs: "../../gibbon-rts/build" extra-libraries: gibbon_rts_ng + extra-lib-dirs: /home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build executable run-gibbon-examples @@ -44,8 +45,10 @@ executable run-gibbon-examples build-depends: base, gibbon-examples, binary, bytestring, deepseq, time ghc-options: -O2 -dcore-lint - include-dirs: "../../gibbon-rts/build" - extra-lib-dirs: "../../gibbon-rts/build" + -- include-dirs: "../../gibbon-rts/build" + -- extra-lib-dirs: "../../gibbon-rts/build" extra-libraries: gibbon_rts_ng - -- ghc-options: "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + extra-lib-dirs: /home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build + ghc-options: + -- "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" + "-optl-Wl,-L/home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build" diff --git a/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs index d5dc454aa..866c13161 100644 --- a/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs +++ b/gibbon-ghc-integration/gibbon-plugin/src/Gibbon/Plugin.hs @@ -96,7 +96,9 @@ gibbonPlugin mod_guts = do -- (5) Link the .o file in the module. let objfile = replaceExtension fp ".o" - let rtsfile = "/home/ckoparka/chai/tree-velocity/gibbon-rts/build/gibbon_rts.o" + GHC.liftIO $ Gib.compileRTS gibbonConfigForPlugin + lib_dir <- GHC.liftIO Gib.getRTSBuildDir + let rtsfile = lib_dir "gibbon_rts.o" let mod_guts' = mod_guts { GHC.mg_foreign_files = (GHC.mg_foreign_files mod_guts) ++ [ ( GHC.RawObject, objfile) , ( GHC.RawObject, rtsfile) @@ -128,14 +130,18 @@ gibbonPlugin mod_guts = do -------------------------------------------------------------------------------- +gibbonConfigForPlugin :: Gib.Config +gibbonConfigForPlugin = let + config = Gib.defaultConfig { Gib.mode = Gib.Library (Gib.toVar "xxx") } + dflags' = Gib.gopt_set Gib.Opt_DisableGC $ Gib.gopt_set Gib.Opt_Packed (Gib.dynflags config) + in + config { Gib.dynflags = dflags', Gib.optc = " -O3 " } + generateObjectFile :: Gib.Prog0 -> IO FilePath generateObjectFile l0 = do - let config = Gib.defaultConfig { Gib.mode = Gib.Library (Gib.toVar "xxx") } - let dflags' = Gib.gopt_set Gib.Opt_DisableGC $ Gib.gopt_set Gib.Opt_Packed (Gib.dynflags config) - let config' = config { Gib.dynflags = dflags', Gib.optc = " -O3 " } uniq <- randomIO :: IO Word16 let fp = "/tmp/gibbon-ghc-integration-file-" ++ show uniq ++ ".hs" - Gib.compileFromL0 config' 0 fp l0 + Gib.compileFromL0 gibbonConfigForPlugin 0 fp l0 return fp -------------------------------------------------------------------------------- From 92e90f94223152d5ebfde62c6c24025352589b52 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Fri, 21 Jun 2024 15:11:43 +0000 Subject: [PATCH 7/8] it works! but it's ugly... the key was "-optl-Wl,-rpath" I think Caveats: - I'm back to absoulute paths in the cabal file. I reconsidered the issue of absolute paths in .cabal files a little: if it's a client's .cabal file, than it's acceptable, albeit not great, I think. We'll see if this is avoidable. With the shared lib in RTS, I'm not sure it is. - I had to get back to once used "-optl-Wl,--allow-multiple-definition". We need to investigate why we get "multiple defintions" and how to avoid this. - I had to simplify the example client package to only have an exe rather than exe+lib. I assume this can be resolved. --- .../examples/gibbon-examples.cabal | 45 ++++--------------- .../examples/{app => src}/Main.hs | 0 .../examples/{app => src}/Measure.hs | 0 3 files changed, 8 insertions(+), 37 deletions(-) rename gibbon-ghc-integration/examples/{app => src}/Main.hs (100%) rename gibbon-ghc-integration/examples/{app => src}/Measure.hs (100%) diff --git a/gibbon-ghc-integration/examples/gibbon-examples.cabal b/gibbon-ghc-integration/examples/gibbon-examples.cabal index 94fcc7cb0..45183c8f6 100644 --- a/gibbon-ghc-integration/examples/gibbon-examples.cabal +++ b/gibbon-ghc-integration/examples/gibbon-examples.cabal @@ -1,54 +1,25 @@ -cabal-version: >=1.10 +cabal-version: 2.0 name: gibbon-examples version: 0.1.0.0 build-type: Simple -library +executable run-gibbon-examples hs-source-dirs: src - exposed-modules: BinTree + main-is: Main.hs + other-modules: BinTree, Measure build-depends: base , inline-c , binary + , deepseq, time, bytestring , gibbon-plugin - ghc-options: -Wall -Wcompat -fdefer-typed-holes + ghc-options: default-language: Haskell2010 ghc-options: -Wall -Wcompat -O2 -fplugin=Gibbon.Plugin + "-optl-Wl,--allow-multiple-definition" + "-optl-Wl,-rpath,/home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build" - -- "-optl-Wl,--allow-multiple-definition" - -- "-optl-Wl,--whole-archive" - -- -- "-optl-Wl,-Bstatic" - -- -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-ghc-integration/plugin1/cbits/" - -- -- "-optl-Wl,-ltest2" - -- "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - -- "-optl-Wl,-lgibbon_rts_ng" - -- -- "-optl-Wl,-Bdynamic" - -- -- "-optl-Wl,-L/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - -- "-optl-Wl,--no-whole-archive" - - -dcore-lint - -ddump-simpl -dsuppress-all -ddump-to-file - - -- include-dirs: "../../gibbon-rts/build" - -- extra-lib-dirs: "../../gibbon-rts/build" extra-libraries: gibbon_rts_ng extra-lib-dirs: /home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build - - -executable run-gibbon-examples - hs-source-dirs: app - default-language: Haskell2010 - main-is: Main.hs - build-depends: base, gibbon-examples, binary, bytestring, deepseq, time - ghc-options: -O2 - -dcore-lint - -- include-dirs: "../../gibbon-rts/build" - -- extra-lib-dirs: "../../gibbon-rts/build" - extra-libraries: gibbon_rts_ng - extra-lib-dirs: /home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build - ghc-options: - -- "-optl-Wl,-I/home/ckoparka/chai/tree-velocity/gibbon-rts/build" - "-optl-Wl,-L/home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build" diff --git a/gibbon-ghc-integration/examples/app/Main.hs b/gibbon-ghc-integration/examples/src/Main.hs similarity index 100% rename from gibbon-ghc-integration/examples/app/Main.hs rename to gibbon-ghc-integration/examples/src/Main.hs diff --git a/gibbon-ghc-integration/examples/app/Measure.hs b/gibbon-ghc-integration/examples/src/Measure.hs similarity index 100% rename from gibbon-ghc-integration/examples/app/Measure.hs rename to gibbon-ghc-integration/examples/src/Measure.hs From cae17fc65c71fb1796dc46e12e543ba8c41f6a34 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Wed, 17 Jul 2024 15:04:16 +0000 Subject: [PATCH 8/8] don't eliminate dead code in library mode but do keep doing it otherwise --- gibbon-compiler/src/Gibbon/Passes/Simplifier.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs index bf2a52548..e2e91b059 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs @@ -93,8 +93,10 @@ simplifyL1 p0 = do p0' <- freshNames1 p0 p1 <- markRecFns p0' p2 <- inlineFuns p1 - -- p3 <- deadFunElim p2 - pure p2 + Config{mode} <- ask + if isLibrary mode + then pure p2 + else deadFunElim p2 --------------------------------------------------------------------------------