Different attempts at optimization

app/main.hs

@@ -1,30 +1,72 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-import Import
-import Run
-import RIO.Process
-import Options.Applicative.Simple
-import qualified Paths_haskell_lox
+{-# LANGUAGE BangPatterns#-}
+
+-- data RunningTotal = RunningTotal
+--   { sum :: !Int
+--   , count :: !Int
+--   }
+
+-- printAverage :: RunningTotal -> IO ()
+-- printAverage (RunningTotal !sum !count)
+--   | count == 0 = error "Need at least one value!"
+--   | otherwise = print (fromIntegral sum / fromIntegral count :: Double)
+
+-- -- | A fold would be nicer... we'll see that later
+-- printListAverage :: [Int] -> IO ()
+-- printListAverage =
+--   go (RunningTotal 0 0)
+--   where
+--     go rt [] = printAverage rt
+--     go (RunningTotal sum count) (x:xs) =
+--       let
+--         !sum' = sum + x
+--         !count' = count + 1
+--         rt = RunningTotal sum' count'
+--        in go rt xs
+
+
+-- data Foo = Foo Int
+-- data Bar = Bar !Int
+-- newtype Baz = Baz Int
+
+-- main :: IO ()
+-- main = do
+--   putStrLn "inside main"
+--   printListAverage [1..1000000]
+--   Baz undefined `seq` putStrLn "Still alive!"
+
+#!/usr/bin/env stack
+-- stack --resolver lts-12.21 script
+
+-- main :: IO ()
+-- main =
+--   let nums = [1..10000000 :: Int]
+--    in print $ fromIntegral (sum nums) / fromIntegral (length nums)
 
 main :: IO ()
-main = do
-  (options, ()) <- simpleOptions
-    $(simpleVersion Paths_haskell_lox.version)
-    "Header for command line arguments"
-    "Program description, also for command line arguments"
-    (Options
-       <$> switch ( long "verbose"
-                 <> short 'v'
-                 <> help "Verbose output?"
-                  )
-    )
-    empty
-  lo <- logOptionsHandle stderr (optionsVerbose options)
-  pc <- mkDefaultProcessContext
-  withLogFunc lo $ \lf ->
-    let app = App
-          { appLogFunc = lf
-          , appProcessContext = pc
-          , appOptions = options
-          }
-     in runRIO app run
+main =
+  let nums1 = [1 .. 10000000 :: Int]
+      nums2 = [1 .. 10000000 :: Int]
+   in print $ fromIntegral (sum nums1) / fromIntegral (length nums2)
+
+-- main :: IO ()
+-- main = do
+--   (options, ()) <- simpleOptions
+--     $(simpleVersion Paths_haskell_lox.version)
+--     "Header for command line arguments"
+--     "Program description, also for command line arguments"
+--     (Options
+--        <$> switch ( long "verbose"
+--                  <> short 'v'
+--                  <> help "Verbose output?"
+--                   )
+--     )
+--     empty
+--   lo <- logOptionsHandle stderr (optionsVerbose options)
+--   pc <- mkDefaultProcessContext
+--   withLogFunc lo $ \lf ->
+--     let app = App
+--           { appLogFunc = lf
+--           , appProcessContext = pc
+--           , appOptions = options
+--           }
+--      in runRIO app run

package.yaml

@@ -81,25 +81,26 @@ executables:
     - optparse-simple
 
     ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
+    #- -rtsopts
     - -O2
     - -funfolding-use-threshold=16
     - -fexcess-precision
     - -optc-ffast-math
+    - -fprof-auto
+    #- -threaded
+    #- -with-rtsopts=-N
 
-  # haskell-lox-exe:
-  #   main:                main.hs
-  #   source-dirs:         app
-  #   dependencies:
-  #   - haskell-lox
-  #   - optparse-simple
+  haskell-lox-exe:
+    main:                main.hs
+    source-dirs:         app
+    dependencies:
+    - haskell-lox
+    - optparse-simple
 
-  #   ghc-options:
-  #   - -threaded
-  #   - -rtsopts
-  #   - -with-rtsopts=-N
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
 
 tests:
   haskell-lox-test-1:

src/ExprInterpreter.hs

@@ -31,19 +31,20 @@ data LoxError = SystemError !T.Text | ControlFlow !LoxValue deriving (Show, Eq)
 -- https://www.seas.upenn.edu/~cis552/13fa/lectures/FunEnv.html
 data LoxValue
   = LoxValueString !T.Text
-  | LoxValueDouble !Double
+  | LoxValueDouble {-# UNPACK #-} !Double
   | LoxValueNil
-  | LoxValueBool !Bool
+  | LoxValueBool {-# UNPACK #-}!Bool
   | LoxValueIdentifier !T.Text
   | LoxValueSentinel -- This is more for the interpreter to return from statements
-  | LoxValueReturn !LoxValue
+  | LoxValueReturn {-# UNPACK #-}!LoxValue
   | LoxValueFunction !T.Text [T.Text] [Declaration] !Env -- Hold on to the AST and Closure
   deriving (Show, Eq)
 
 isTruthy :: LoxValue -> Bool
 isTruthy LoxValueNil = False
 isTruthy (LoxValueBool !x) = x
 isTruthy _ = True
+--{-# INLINE isTruthy #-}
 
 -- type Env = M.Map T.Text LoxValue
 
@@ -55,6 +56,7 @@ data Env = Env {
 
 initEnv :: Maybe Env -> Env
 initEnv !parent = Env {env=M.empty, parent=parent}
+--{-# INLINE initEnv #-}
 
 lookupEnv :: T.Text -> Env -> Maybe LoxValue
 lookupEnv !k !environ = go (Just environ)
@@ -63,6 +65,7 @@ lookupEnv !k !environ = go (Just environ)
                            Just v -> Just $! v
                            Nothing -> go parent
     go Nothing = Nothing
+--{-# INLINE lookupEnv #-}
 
 updateEnv :: T.Text -> LoxValue -> Env -> Maybe Env
 updateEnv !k !v !s = go (Just $! s)
@@ -76,14 +79,15 @@ updateEnv !k !v !s = go (Just $! s)
 
 insertEnv :: T.Text -> LoxValue -> Env -> Env
 insertEnv !k !v s@Env {..} = s {env = M.insert k v env}
+--{-# INLINE insertEnv #-}
 
 multiInsertEnv :: [(T.Text, LoxValue)] -> Env -> Env
 multiInsertEnv !values s@Env {..} = let
   new_env = M.fromList values
   !new_env' = M.union new_env env
   in
   s {env=new_env'}
-
+-- {-# INLINE multiInsertEnv #-}
 
 showLoxValue :: LoxValue -> String
 showLoxValue (LoxValueString t) = show t
@@ -101,6 +105,7 @@ unpackIdent (LoxValueIdentifier x) = do
     Just v' -> lift . return $ v'
     Nothing -> ExceptT . return $ Left $ SystemError $ "Unknown var: " <> x
 unpackIdent x = lift . return $ x
+--{-# INLINE unpackIdent #-}
 
 type InterpreterTIO = ExceptT LoxError (StateT Env IO) LoxValue
 
@@ -116,6 +121,8 @@ applyOpToDouble !x !y !bop _ = ExceptT . return $ Left $ SystemError value
           ++ show x
           ++ " and "
           ++ show y
+--{-# INLINE applyOpToDouble #-}
+
 applyCompOpToDouble :: LoxValue -> LoxValue -> BinOp -> (Double -> Double -> Bool) -> InterpreterTIO
 applyCompOpToDouble (LoxValueDouble !x) (LoxValueDouble !y) bop op = lift . return $ LoxValueBool $ op x y
 applyCompOpToDouble !x !y !bop _ = ExceptT . return $ Left $ SystemError value
@@ -128,6 +135,7 @@ applyCompOpToDouble !x !y !bop _ = ExceptT . return $ Left $ SystemError value
           ++ show x
           ++ " and "
           ++ show y
+--{-# INLINE applyCompOpToDouble #-}
 
 interpret :: Expr -> InterpreterTIO
 interpret (Number !x) = lift $ return $ LoxValueDouble x
@@ -205,9 +213,9 @@ interpret (Call !expr !arguments _) = do
     LoxValueFunction !func_name !params !block !closure -> do
       let !pa = L.zip params args
       --liftIO $ putStrLn $ show s'
-      let s = multiInsertEnv pa (initEnv (Just closure))
+      let !s = multiInsertEnv pa (initEnv (Just closure))
       -- we need to insert this back here to resolve circular dependency
-      let s' = insertEnv func_name (LoxValueFunction func_name params block closure) s
+      let !s' = insertEnv func_name (LoxValueFunction func_name params block closure) s
       put $! s'
       !value <- catchError (interpretProgram block) f
       put orig
@@ -217,6 +225,7 @@ interpret (Call !expr !arguments _) = do
     f (SystemError e) = ExceptT . return . Left $ SystemError e
     f (ControlFlow (LoxValueReturn e)) = return e
     f (ControlFlow v) = ExceptT . return . Left $ SystemError $ "Unknown handler:" <> T.pack (show v)
+--{-# INLINE interpret #-}
 
 interpretStmt :: Statement -> InterpreterTIO
 interpretStmt (StmtExpr expr) = do
@@ -267,6 +276,8 @@ interpretStmt (StmtReturn (Just !expr)) = do
   return $ LoxValueReturn result
 interpretStmt (StmtReturn Nothing) = return $ LoxValueReturn $ LoxValueDouble 9999.0
 
+-- {-# INLINE interpretStmt #-}
+
 -- interpretDeclaration :: Declaration -> Env -> IO (Env, Maybe T.Text)
 interpretDeclaration :: Declaration -> InterpreterTIO
 interpretDeclaration (DeclVar (Decl !var (Just !expr))) = do
@@ -285,10 +296,11 @@ interpretDeclaration (DeclStatement !stmt) = interpretStmt stmt
 
 interpretDeclaration (DeclFun (Func !func_name !params !block)) = do
   closure <- get
-  let func = LoxValueFunction func_name params block closure
-  let closure' = insertEnv func_name func closure -- capture the closure, add back func later on
+  let !func = LoxValueFunction func_name params block closure
+  let !closure' = insertEnv func_name func closure -- capture the closure, add back func later on
   put closure'
   return LoxValueSentinel
+--{-# INLINE interpretDeclaration #-}
 
 interpretProgram :: Program -> InterpreterTIO
 interpretProgram = go