wip: GHC integration

Author: ckoparkar

gibbon-compiler/src/Gibbon/Common.hs

@@ -232,6 +232,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

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
@@ -272,19 +278,8 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do
                   C    -> codegenProg config' l4
 
 
-
-                  LLVM -> error $ "Cannot execute through the LLVM backend. To build Gibbon with LLVM: "
-                          ++ "stack build --flag gibbon:llvm_enabled"
-
-          -- The C code is long, so put this at a higher verbosity level.
-          dbgPrint passChatterLvl $ " [compiler] Final C codegen: " ++show (length str) ++" characters."
-          dbgPrintLn 4 $ sepline ++ "\n" ++ str
-
-          clearFile outfile
-          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 +418,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 +428,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 +538,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

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

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
 
 --------------------------------------------------------------------------------
 

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,6 +1,7 @@
 packages: ../gibbon-compiler
           plugin0
           plugin1
+          gibbon-plugin
           examples
 
 with-compiler: ghc-9.4.3

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 ()

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)

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
+  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"