GHC plugin update

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
@@ -252,8 +253,17 @@ 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)
 
+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)

gibbon-compiler/src/Gibbon/Compiler.hs

@@ -9,12 +9,13 @@
 
 module Gibbon.Compiler
     ( -- * Compiler entrypoints
-      compile, compileCmd
+      compile, compileFromL0, compileCmd
       -- * Configuration options and parsing
      , Config (..), Mode(..), Input(..)
      , configParser, configWithArgs, defaultConfig
       -- * Some other helper fns
      , compileAndRunExe
+     , getRTSBuildDir, compileRTS
     )
   where
 
@@ -163,7 +164,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 +212,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 +221,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 +278,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 +289,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 +428,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 +438,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
@@ -536,11 +543,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
-
 -- | The debug level at which we start to call the interpreter on the program during compilation.
 interpDbgLevel :: Int
 interpDbgLevel = 5

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,12 @@ 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
       main_expr = do

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 p3
+    Config{mode} <- ask
+    if isLibrary mode
+      then pure p2
+      else deadFunElim p2
 
 --------------------------------------------------------------------------------
 

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
 

gibbon-ghc-integration/cabal.project

@@ -1,9 +1,6 @@
 packages: ../gibbon-compiler
-          plugin0
-          plugin1
+          gibbon-plugin
           examples
 
-with-compiler: ghc-9.4.3
-
 package *
   ghc-options: -fexpose-all-unfoldings

gibbon-ghc-integration/examples/gibbon-examples.cabal

@@ -1,41 +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
-  build-depends:       base == 4.17.*
-                     , plugin0
-                     , plugin1
+  main-is:             Main.hs
+  other-modules:       BinTree, Measure
+  build-depends:       base
                      , inline-c
                      , binary
-  ghc-options: -Wall -Wcompat -fdefer-typed-holes
+                     , deepseq, time, bytestring
+                     , gibbon-plugin
+  ghc-options:
   default-language:    Haskell2010
   ghc-options:         -Wall -Wcompat
+                       -O2
                        -fplugin=Gibbon.Plugin
-                       -fplugin=Gibbon.Plugin1
-
                        "-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,--no-whole-archive"
-
-                       -dcore-lint
-                       -ddump-simpl -dsuppress-all -ddump-to-file
+                       "-optl-Wl,-rpath,/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
-  ghc-options:
-                       -- "-with-rtsopts=-T"
-                       -- "-with-rtsopts=-s"
-                       -dcore-lint
+  extra-libraries: gibbon_rts_ng
+  extra-lib-dirs: /home/artem/data/Dev/gibbon/gibbon/gibbon-rts/build

gibbon-ghc-integration/examples/src/BinTree.hs

@@ -4,7 +4,8 @@
 
 module BinTree where
 
-import Gibbon.Plugin ( 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 "print_double"
-  c_print_double :: CDouble -> IO CInt
+foreign import ccall unsafe "c_liftbench1"
+  cfastbench1 :: CInt -> IO CInt
 
-fast_print_double :: Double -> IO Int
-fast_print_double x = do
-  y <- c_print_double (realToFrac x)
+fastbench1 :: Int -> IO Int
+fastbench1 x = do
+  y <- cfastbench1 (fromIntegral x)
   pure $ fromIntegral y
 
 --------------------------------------------------------------------------------
 
+-- 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
+
+--------------------------------------------------------------------------------
+
+
+{-
+
 C.include "<stdlib.h>"
 C.include "<stdio.h>"
 C.include "<stdint.h>"
@@ -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
+
+-}

gibbon-ghc-integration/examples/app/Main.hs → gibbon-ghc-integration/examples/src/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,28 @@ 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 = 25
+  let iters = 9
+  (res0, t0, t_all_0) <- bench bench1 size iters
+
+  (res1, t1, t_all_1) <- benchIO fastbench1 size iters
+
+  print (res0,t0)
+  print (res1,t1)
   pure ()