{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}

-- | The compiler pipeline, assembled from several passes.

module Gibbon.Compiler
    ( -- * Compiler entrypoints
      compile, compileCmd
      -- * Configuration options and parsing
     , Config (..), Mode(..), Input(..)
     , configParser, configWithArgs, defaultConfig
      -- * Some other helper fns
     , compileAndRunExe
    )
  where

import           Data.Functor
import           Control.DeepSeq
import           Control.Exception
#if !MIN_VERSION_base(4,15,0)
#endif
import           Control.Monad
import           Control.Monad.State.Strict
import           Control.Monad.Reader (ask)



import           Options.Applicative
import           System.Directory
import           System.Environment
import           System.Exit
import           System.FilePath
import           System.IO
import           System.IO.Error (isDoesNotExistError)
import           System.Process
import           Text.PrettyPrint.GenericPretty

import           Gibbon.Common
import           Gibbon.DynFlags
import           Gibbon.Language
import qualified Gibbon.HaskellFrontend as HS
import qualified Gibbon.L0.Syntax as L0
import qualified Gibbon.L1.Syntax as L1
import qualified Gibbon.L2.Syntax as L2
import qualified Gibbon.L4.Syntax as L4
import qualified Gibbon.SExpFrontend as SExp
import           Gibbon.L0.Interp()
import           Gibbon.L1.Interp()
import           Gibbon.L2.Interp ( Store, emptyStore )
-- import           Gibbon.TargetInterp (Val (..), execProg)

-- Compiler passes
import qualified Gibbon.L0.Typecheck as L0
import qualified Gibbon.L0.Specialize2 as L0
import qualified Gibbon.L0.ElimNewtype as L0
import qualified Gibbon.L1.Typecheck as L1
import qualified Gibbon.L2.Typecheck as L2
import qualified Gibbon.L3.Typecheck as L3
import           Gibbon.Passes.Freshen        (freshNames)
import           Gibbon.Passes.Flatten        (flattenL1, flattenL2, flattenL3)
import           Gibbon.Passes.InlineTriv     (inlineTriv)
import           Gibbon.Passes.Simplifier     (simplifyL1, lateInlineTriv, simplifyLocBinds)
-- import           Gibbon.Passes.Sequentialize  (sequentialize)

import           Gibbon.Passes.DirectL3       (directL3)
import           Gibbon.Passes.InferLocations (inferLocs, fixRANs, removeAliasesForCopyCalls)
-- This is the custom pass reference to issue #133 that moves regionsInwards
import           Gibbon.Passes.RegionsInwards (regionsInwards)
-- import           Gibbon.Passes.RepairProgram  (repairProgram)
import           Gibbon.Passes.AddRAN         (addRAN,needsRAN)
import           Gibbon.Passes.AddTraversals  (addTraversals)
import           Gibbon.Passes.RemoveCopies   (removeCopies)
import           Gibbon.Passes.InferEffects   (inferEffects)
import           Gibbon.Passes.ParAlloc       (parAlloc)
import           Gibbon.Passes.InferRegionScope (inferRegScope)
import           Gibbon.Passes.RouteEnds      (routeEnds)
import           Gibbon.Passes.FollowPtrs     (followPtrs)
import           Gibbon.NewL2.FromOldL2       (fromOldL2)
import           Gibbon.Passes.ThreadRegions  (threadRegions)
import           Gibbon.Passes.InferFunAllocs (inferFunAllocs)
import           Gibbon.Passes.Cursorize      (cursorize)
import           Gibbon.Passes.FindWitnesses  (findWitnesses)
-- -- import           Gibbon.Passes.ShakeTree      (shakeTree)
import           Gibbon.Passes.HoistNewBuf    (hoistNewBuf)
import           Gibbon.Passes.ReorderScalarWrites  ( reorderScalarWrites, writeOrderMarkers )
import           Gibbon.Passes.Unariser       (unariser)
import           Gibbon.Passes.Lower          (lower)
import           Gibbon.Passes.RearrangeFree  (rearrangeFree)
import           Gibbon.Passes.Codegen        (codegenProg)
import           Gibbon.Passes.Fusion2        (fusion2)
import           Gibbon.Pretty
import           Gibbon.L1.GenSML
-- Configuring and launching the compiler.
--------------------------------------------------------------------------------

suppress_warnings :: String
-- suppress_warnings = " -Wno-int-to-pointer-cast -Wno-switch-bool -Wno-return-type "
suppress_warnings :: String
suppress_warnings = String
""

configParser :: Parser Config
configParser :: Parser Config
configParser = Input
-> Mode
-> Maybe String
-> Maybe String
-> Int
-> String
-> String
-> Maybe String
-> Maybe String
-> Backend
-> DynFlags
-> Maybe String
-> Config
Config (Input
 -> Mode
 -> Maybe String
 -> Maybe String
 -> Int
 -> String
 -> String
 -> Maybe String
 -> Maybe String
 -> Backend
 -> DynFlags
 -> Maybe String
 -> Config)
-> Parser Input
-> Parser
     (Mode
      -> Maybe String
      -> Maybe String
      -> Int
      -> String
      -> String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Input
inputParser
                      Parser
  (Mode
   -> Maybe String
   -> Maybe String
   -> Int
   -> String
   -> String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser Mode
-> Parser
     (Maybe String
      -> Maybe String
      -> Int
      -> String
      -> String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Mode
modeParser
                      Parser
  (Maybe String
   -> Maybe String
   -> Int
   -> String
   -> String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser (Maybe String)
-> Parser
     (Maybe String
      -> Int
      -> String
      -> String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields String] -> Mod OptionFields String
forall a. Monoid a => [a] -> a
mconcat
                        [ String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"bench-input"
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILE"
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help (String -> Mod OptionFields String)
-> String -> Mod OptionFields String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                            [ String
"Hard-code the input file for --bench-fun, otherwise it"
                            , String
" becomes a command-line argument of the resulting binary."
                            , String
" Also we RUN the benchmark right away if this is provided."
                            ]
                        ])
                      Parser
  (Maybe String
   -> Int
   -> String
   -> String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser (Maybe String)
-> Parser
     (Int
      -> String
      -> String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields String] -> Mod OptionFields String
forall a. Monoid a => [a] -> a
mconcat
                        [ String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"array-input"
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILE"
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help (String -> Mod OptionFields String)
-> String -> Mod OptionFields String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                          [ String
"Hard-code the input file for readArrayFile or it"
                          , String
" becomes a command-line argument of the resulting binary."
                          ]
                        ])
                      Parser
  (Int
   -> String
   -> String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser Int
-> Parser
     (String
      -> String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto ([Mod OptionFields Int] -> Mod OptionFields Int
forall a. Monoid a => [a] -> a
mconcat
                        [ Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v'
                        , String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"verbose"
                        , String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Set the debug output level, 1-5, mirrors DEBUG env var."
                        ]) Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
                      Parser
  (String
   -> String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser String
-> Parser
     (String
      -> Maybe String
      -> Maybe String
      -> Backend
      -> DynFlags
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"cc" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Set C compiler, default 'gcc'")
                           Parser String -> Parser String -> Parser String
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> String
cc Config
defaultConfig))
                      Parser
  (String
   -> Maybe String
   -> Maybe String
   -> Backend
   -> DynFlags
   -> Maybe String
   -> Config)
-> Parser String
-> Parser
     (Maybe String
      -> Maybe String -> Backend -> DynFlags -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"optc" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Set C compiler options, default '-std=gnu11 -O3'")
                           Parser String -> Parser String -> Parser String
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> String
optc Config
defaultConfig))
                      Parser
  (Maybe String
   -> Maybe String -> Backend -> DynFlags -> Maybe String -> Config)
-> Parser (Maybe String)
-> Parser
     (Maybe String -> Backend -> DynFlags -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Maybe String) -> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"cfile" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Set the destination file for generated C code")
                           Parser (Maybe String)
-> Parser (Maybe String) -> Parser (Maybe String)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> Parser (Maybe String)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> Maybe String
cfile Config
defaultConfig))
                      Parser
  (Maybe String -> Backend -> DynFlags -> Maybe String -> Config)
-> Parser (Maybe String)
-> Parser (Backend -> DynFlags -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Maybe String) -> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields String] -> Mod OptionFields String
forall a. Monoid a => [a] -> a
mconcat
                        [ Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'o'
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"exefile"
                        , String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Set the destination file for the executable"
                        ]) Parser (Maybe String)
-> Parser (Maybe String) -> Parser (Maybe String)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> Parser (Maybe String)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> Maybe String
exefile Config
defaultConfig))
                      Parser (Backend -> DynFlags -> Maybe String -> Config)
-> Parser Backend -> Parser (DynFlags -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Backend
backendParser
                      Parser (DynFlags -> Maybe String -> Config)
-> Parser DynFlags -> Parser (Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser DynFlags
dynflagsParser
                      Parser (Maybe String -> Config)
-> Parser (Maybe String) -> Parser Config
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption Mod OptionFields String
forall (f :: * -> *) a. Mod f a
hidden)
 where
  inputParser :: Parser Input
                -- I'd like to display a separator and some more info.  How?
  inputParser :: Parser Input
inputParser = -- infoOption "foo" (help "bar") <*>
                Input -> Mod FlagFields Input -> Parser Input
forall a. a -> Mod FlagFields a -> Parser a
flag' Input
Haskell (String -> Mod FlagFields Input
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hs")  Parser Input -> Parser Input -> Parser Input
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                Input -> Input -> Mod FlagFields Input -> Parser Input
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Input
Unspecified Input
SExpr (String -> Mod FlagFields Input
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"gib")

  modeParser :: Parser Mode
modeParser = -- infoOption "foo" (help "bar") <*>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
ToParse (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"parse" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Only parse, then print & stop") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
ToC     (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"toC" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Compile to a C file, named after the input") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>



               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
ToExe   (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"to-exe" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Compile to a C file, named after the input") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
Interp1 (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"interp1" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"run through the interpreter early, right after parsing") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
Interp2 (Char -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i' Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"interp2" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<>
                              String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Run through the interpreter after cursor insertion") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
RunExe  (Char -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r' Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"run" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Compile and then run executable") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
ToMPL (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mpl" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Emit MPL sources") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
ToMPLExe (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mpl-exe" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Emit SML and compile with MPL") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Mode -> Mod FlagFields Mode -> Parser Mode
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
RunMPL (String -> Mod FlagFields Mode
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mpl-run" Mod FlagFields Mode -> Mod FlagFields Mode -> Mod FlagFields Mode
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Mode
forall (f :: * -> *) a. String -> Mod f a
help String
"Emit SML, compile with MPL, and run") Parser Mode -> Parser Mode -> Parser Mode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               (Var -> Mode
Bench (Var -> Mode) -> (String -> Var) -> String -> Mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Var
toVar (String -> Mode) -> Parser String -> Parser Mode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'b' Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"bench-fun" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FUN" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
                                     String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help (String
"Generate code to benchmark a 1-argument FUN against a input packed file."String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                           String
"  If --bench-input is provided, then the benchmark is run as well.")))

  -- use C as the default backend
  backendParser :: Parser Backend
  backendParser :: Parser Backend
backendParser = Backend -> Backend -> Mod FlagFields Backend -> Parser Backend
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Backend
C Backend
LLVM (String -> Mod FlagFields Backend
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"llvm" Mod FlagFields Backend
-> Mod FlagFields Backend -> Mod FlagFields Backend
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Backend
forall (f :: * -> *) a. String -> Mod f a
help String
"use the llvm backend for compilation")


-- | Parse configuration as well as file arguments.
configWithArgs :: Parser (Config,[FilePath])
configWithArgs :: Parser (Config, [String])
configWithArgs = (,) (Config -> [String] -> (Config, [String]))
-> Parser Config -> Parser ([String] -> (Config, [String]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Config
configParser
                     Parser ([String] -> (Config, [String]))
-> Parser [String] -> Parser (Config, [String])
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILES..." Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Files to compile."))

--------------------------------------------------------------------------------

-- | Command line version of the compiler entrypoint.  Parses command
-- line arguments given as string inputs.  This also allows us to run
-- conveniently from within GHCI.  For example:
--
-- >  compileCmd $ words $ " -r -p -v5 examples/test11c_funrec.gib "
--
compileCmd :: [String] -> IO ()
compileCmd :: [String] -> IO ()
compileCmd [String]
args = [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs [String]
args (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    do (Config
cfg,[String]
files) <- ParserInfo (Config, [String]) -> IO (Config, [String])
forall a. ParserInfo a -> IO a
execParser ParserInfo (Config, [String])
opts
       case [String]
files of
         [String
f] -> Config -> String -> IO ()
compile Config
cfg String
f
         [String]
_ -> do Int -> String -> IO ()
dbgPrintLn Int
1 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Compiling multiple files:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
files
                 (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> String -> IO ()
compile Config
cfg) [String]
files
  where
    opts :: ParserInfo (Config, [String])
opts = Parser (Config, [String])
-> InfoMod (Config, [String]) -> ParserInfo (Config, [String])
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ((Config, [String]) -> (Config, [String]))
forall a. Parser (a -> a)
helper Parser ((Config, [String]) -> (Config, [String]))
-> Parser (Config, [String]) -> Parser (Config, [String])
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Config, [String])
configWithArgs) (InfoMod (Config, [String]) -> ParserInfo (Config, [String]))
-> InfoMod (Config, [String]) -> ParserInfo (Config, [String])
forall a b. (a -> b) -> a -> b
$ [InfoMod (Config, [String])] -> InfoMod (Config, [String])
forall a. Monoid a => [a] -> a
mconcat
      [ InfoMod (Config, [String])
forall a. InfoMod a
fullDesc
      , String -> InfoMod (Config, [String])
forall a. String -> InfoMod a
progDesc String
"Compile FILES according to the below options."
      , String -> InfoMod (Config, [String])
forall a. String -> InfoMod a
header String
"A compiler for a minature tree traversal language"
      ]


sepline :: String
sepline :: String
sepline = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
80 Char
'='


data CompileState a = CompileState
    { forall a. CompileState a -> Int
cnt :: Int -- ^ Gensym counter
    , forall a. CompileState a -> Maybe (Value a)
result :: Maybe (Value a) -- ^ Result of evaluating output of prior pass, if available.
    }

-- | Compiler entrypoint, given a full configuration and a list of
-- files to process, do the thing.
compile :: Config -> FilePath -> IO ()
compile :: Config -> String -> IO ()
compile config :: Config
config@Config{Mode
mode :: Mode
mode :: Config -> Mode
mode,Input
input :: Input
input :: Config -> Input
input,Int
verbosity :: Int
verbosity :: Config -> Int
verbosity,Backend
backend :: Backend
backend :: Config -> Backend
backend,Maybe String
cfile :: Config -> Maybe String
cfile :: Maybe String
cfile} String
fp0 = do
  -- set the env var DEBUG, to verbosity, when > 1
  Int -> IO ()
setDebugEnvVar Int
verbosity

  -- Use absolute path
  String
dir <- IO String
getCurrentDirectory
  let fp1 :: String
fp1 = String
dir String -> String -> String
</> String
fp0
  -- Parse the input file
  ((Prog0
l0, Int
cnt0), String
fp) <- Config -> Input -> String -> IO ((Prog0, Int), String)
parseInput Config
config Input
input String
fp1
  let config' :: Config
config' = Config
config { srcFile :: Maybe String
srcFile = String -> Maybe String
forall a. a -> Maybe a
Just String
fp }

  let initTypeChecked :: L0.Prog0
      initTypeChecked :: Prog0
initTypeChecked =
        -- We typecheck first to turn the appropriate VarE's into FunRefE's.
        (Prog0, Int) -> Prog0
forall a b. (a, b) -> a
fst ((Prog0, Int) -> Prog0) -> (Prog0, Int) -> Prog0
forall a b. (a -> b) -> a -> b
$ Config -> Int -> PassM Prog0 -> (Prog0, Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
defaultConfig Int
cnt0
                (Prog0 -> PassM Prog0
freshNames Prog0
l0 PassM Prog0 -> (Prog0 -> PassM Prog0) -> PassM Prog0
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                 (\Prog0
fresh -> Int -> String -> PassM Prog0 -> PassM Prog0
forall a. Int -> String -> a -> a
dbgTrace Int
5 (String
"\nFreshen:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
seplineString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++Prog0 -> String
forall e. Pretty e => e -> String
pprender Prog0
fresh) (Prog0 -> PassM Prog0
L0.tcProg Prog0
fresh)))

  case Mode
mode of
    Mode
Interp1 -> do
        Int -> String -> IO () -> IO ()
forall a. Int -> String -> a -> a
dbgTrace Int
passChatterLvl (String
"\nParsed:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
seplineString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Prog0 -> String
forall a. Out a => a -> String
sdoc Prog0
l0) (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Int -> String -> IO () -> IO ()
forall a. Int -> String -> a -> a
dbgTrace Int
passChatterLvl (String
"\nTypechecked:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
seplineString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Prog0 -> String
forall e. Pretty e => e -> String
pprender Prog0
initTypeChecked) (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig []
        (()
_s1,Value Exp0
val,ByteString
_stdout) <- () -> RunConfig -> Prog0 -> IO ((), Value Exp0, ByteString)
forall s e.
InterpProg s e =>
s -> RunConfig -> Prog e -> IO (s, Value e, ByteString)
gInterpProg () RunConfig
runConf Prog0
initTypeChecked
        Value Exp0 -> IO ()
forall a. Show a => a -> IO ()
print Value Exp0
val


    Mode
ToParse -> Int -> String -> IO ()
dbgPrintLn Int
0 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Prog0 -> String
forall e. Pretty e => e -> String
pprender Prog0
l0

    Mode
_ -> do
      Int -> String -> IO ()
dbgPrintLn Int
passChatterLvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
" [compiler] pipeline starting, parsed program: "String -> String -> String
forall a. [a] -> [a] -> [a]
++
            if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
passChatterLvlInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
            then String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sepline String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Prog0 -> String
forall a. Out a => a -> String
sdoc Prog0
l0
            else Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Prog0 -> String
forall a. Out a => a -> String
sdoc Prog0
l0)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" characters."

      -- (Stage 1) Run the program through the interpreter
      Maybe (Value Exp0)
initResult <- Prog0 -> IO (Maybe (Value Exp0))
withPrintInterpProg Prog0
initTypeChecked

      -- (Stage 2) C/LLVM codegen
      let outfile :: String
outfile = Backend -> String -> Maybe String -> String
getOutfile Backend
backend String
fp Maybe String
cfile

      -- run the initial program through the compiler pipeline
      let stM :: StateT (CompileState Exp0) IO Prog
stM = Config -> Prog0 -> StateT (CompileState Exp0) IO Prog
forall v.
Show v =>
Config -> Prog0 -> StateT (CompileState v) IO Prog
passes Config
config' Prog0
l0
      Prog
l4  <- StateT (CompileState Exp0) IO Prog -> CompileState Exp0 -> IO Prog
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (CompileState Exp0) IO Prog
stM (CompileState {cnt :: Int
cnt=Int
cnt0, result :: Maybe (Value Exp0)
result=Maybe (Value Exp0)
initResult})

      case Mode
mode of
        Mode
Interp2 -> do
          String -> IO ()
forall a. HasCallStack => String -> a
error String
"TODO: Interp2"
          -- l4res <- execProg l4
          -- mapM_ (\(IntVal v) -> liftIO $ print v) l4res
          -- exitSuccess
        
        Mode
ToMPL -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Mode
ToMPLExe -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Mode
RunMPL -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        Mode
_ -> do
          String
str <- case Backend
backend of
                  Backend
C    -> Config -> Prog -> IO String
codegenProg Config
config' Prog
l4



                  Backend
LLVM -> String -> IO String
forall a. HasCallStack => String -> a
error (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Cannot execute through the LLVM backend. To build Gibbon with LLVM: "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"stack build --flag gibbon:llvm_enabled"

          -- The C code is long, so put this at a higher verbosity level.
          Int -> String -> IO ()
dbgPrint Int
passChatterLvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" [compiler] Final C codegen: " String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" characters."
          Int -> String -> IO ()
dbgPrintLn Int
4 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
sepline String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

          String -> IO ()
clearFile String
outfile
          String -> String -> IO ()
writeFile String
outfile String
str

          -- (Stage 3) Code written, now compile if warranted.
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
ToExe Bool -> Bool -> Bool
|| Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
RunExe Bool -> Bool -> Bool
|| Mode -> Bool
isBench Mode
mode ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Config -> String -> IO String
compileAndRunExe Config
config String
fp IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr
            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runL0 :: L0.Prog0 -> IO ()
runL0 :: Prog0 -> IO ()
runL0 Prog0
l0 = do
    -- FIXME: no command line option atm.  Just env vars.
    RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig []
    Int -> String -> IO ()
dbgPrintLn Int
2 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running the following through L0.Interp:\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sepline String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Prog0 -> String
forall a. Out a => a -> String
sdoc Prog0
l0
    () -> RunConfig -> Prog0 -> IO ()
forall s ex. InterpProg s ex => s -> RunConfig -> Prog ex -> IO ()
execAndPrint () RunConfig
runConf Prog0
l0
    IO ()
forall a. IO a
exitSuccess

-- | The compiler's policy for running/printing L1 programs.
runL1 :: L1.Prog1 -> IO ()
runL1 :: Prog1 -> IO ()
runL1 Prog1
l1 = do
    -- FIXME: no command line option atm.  Just env vars.
    RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig []
    Int -> String -> IO ()
dbgPrintLn Int
2 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running the following through L1.Interp:\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sepline String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Prog1 -> String
forall a. Out a => a -> String
sdoc Prog1
l1
    () -> RunConfig -> Prog1 -> IO ()
forall s ex. InterpProg s ex => s -> RunConfig -> Prog ex -> IO ()
execAndPrint () RunConfig
runConf Prog1
l1
    IO ()
forall a. IO a
exitSuccess

-- | The compiler's policy for running/printing L2 programs.
runL2 :: L2.Prog2 -> IO ()
runL2 :: Prog2 -> IO ()
runL2 Prog2
l2 = Prog1 -> IO ()
runL1 (Prog2 -> Prog1
L2.revertToL1 Prog2
l2)

-- | Set the env var DEBUG, to verbosity, when > 1
-- TERRIBLE HACK!!
-- This verbosity value is global, "pure" and can be read anywhere
--
setDebugEnvVar :: Int -> IO ()
setDebugEnvVar :: Int -> IO ()
setDebugEnvVar Int
verbosity =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> String -> IO ()
setEnv String
"GIBBON_DEBUG" (Int -> String
forall a. Show a => a -> String
show Int
verbosity)
    Int
l <- Int -> IO Int
forall a. a -> IO a
evaluate Int
dbgLvl
    Handle -> String -> IO ()
hPutStrLn Handle
stderr(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" ! We set DEBUG based on command-line verbose arg: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
l


parseInput :: Config -> Input -> FilePath -> IO ((L0.Prog0, Int), FilePath)
parseInput :: Config -> Input -> String -> IO ((Prog0, Int), String)
parseInput Config
cfg Input
ip String
fp = do
  (PassM Prog0
l0, String
f) <-
    case Input
ip of
      Input
Haskell -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> String -> IO (PassM Prog0)
HS.parseFile Config
cfg String
fp
      Input
SExpr   -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (PassM Prog0)
SExp.parseFile String
fp
      Input
Unspecified ->
        case String -> String
takeExtension String
fp of
          String
".hs"   -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> String -> IO (PassM Prog0)
HS.parseFile Config
cfg String
fp
          String
".sexp" -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (PassM Prog0)
SExp.parseFile String
fp
          String
".rkt"  -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (PassM Prog0)
SExp.parseFile String
fp
          String
".gib"  -> (, String
fp) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (PassM Prog0)
SExp.parseFile String
fp
          String
oth -> do
            -- A silly hack just out of sheer laziness vis-a-vis tab completion:
            let f1 :: String
f1 = String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".gib"
                f2 :: String
f2 = String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"gib"
            Bool
f1' <- String -> IO Bool
doesFileExist String
f1
            Bool
f2' <- String -> IO Bool
doesFileExist String
f2
            if (Bool
f1' Bool -> Bool -> Bool
&& String
oth String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"") Bool -> Bool -> Bool
|| (Bool
f2' Bool -> Bool -> Bool
&& String
oth String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".")
            then (,String
f2) (PassM Prog0 -> (PassM Prog0, String))
-> IO (PassM Prog0) -> IO (PassM Prog0, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (PassM Prog0)
SExp.parseFile String
f1
            else String -> IO (PassM Prog0, String)
forall a. HasCallStack => String -> a
error (String -> IO (PassM Prog0, String))
-> String -> IO (PassM Prog0, String)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"compile: unrecognized file extension: "
              , String -> String
forall a. Show a => a -> String
show String
oth
              , String
"  Please specify compile input format."
              ]
  let l0' :: PassM Prog0
l0' = do Prog0
parsed <- PassM Prog0
l0
               -- dbgTraceIt (sdoc parsed) (pure ())
               Prog0 -> PassM Prog0
HS.desugarLinearExts Prog0
parsed
  (Prog0
l0'', Int
cnt) <- (Prog0, Int) -> IO (Prog0, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Prog0, Int) -> IO (Prog0, Int))
-> (Prog0, Int) -> IO (Prog0, Int)
forall a b. (a -> b) -> a -> b
$ Config -> Int -> PassM Prog0 -> (Prog0, Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
defaultConfig Int
0 PassM Prog0
l0'
  ((Prog0, Int), String) -> IO ((Prog0, Int), String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Prog0
l0'', Int
cnt), String
f)


-- |
withPrintInterpProg :: L0.Prog0 -> IO (Maybe (Value L0.Exp0))
withPrintInterpProg :: Prog0 -> IO (Maybe (Value Exp0))
withPrintInterpProg Prog0
l0 =
  if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
interpDbgLevel
  then do
    -- FIXME: no command line option atm.  Just env vars.
    RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig []
    (()
_s1,Value Exp0
val,ByteString
_stdout) <- () -> RunConfig -> Prog0 -> IO ((), Value Exp0, ByteString)
forall s e.
InterpProg s e =>
s -> RunConfig -> Prog e -> IO (s, Value e, ByteString)
gInterpProg () RunConfig
runConf Prog0
l0
    Int -> String -> IO ()
dbgPrintLn Int
interpDbgLevel (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" [eval] Init prog evaluated to: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Value Exp0 -> String
forall a. Show a => a -> String
show Value Exp0
val
    Maybe (Value Exp0) -> IO (Maybe (Value Exp0))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value Exp0) -> IO (Maybe (Value Exp0)))
-> Maybe (Value Exp0) -> IO (Maybe (Value Exp0))
forall a b. (a -> b) -> a -> b
$ Value Exp0 -> Maybe (Value Exp0)
forall a. a -> Maybe a
Just Value Exp0
val
  else
    Maybe (Value Exp0) -> IO (Maybe (Value Exp0))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Value Exp0)
forall a. Maybe a
Nothing

compileRTS :: Config -> IO ()
compileRTS :: Config -> IO ()
compileRTS Config{Int
verbosity :: Config -> Int
verbosity :: Int
verbosity,String
optc :: Config -> String
optc :: String
optc,DynFlags
dynflags :: DynFlags
dynflags :: Config -> DynFlags
dynflags} = do
  String
gibbon_dir <- IO String
getGibbonDir
  let rtsmk :: String
rtsmk = String
gibbon_dir String -> String -> String
</> String
"gibbon-rts/Makefile"
  let rtsmkcmd :: String
rtsmkcmd = String
"make -f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rtsmk String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
rts_debug then String
" MODE=debug " else String
" MODE=release ")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
rts_debug Bool -> Bool -> Bool
&& Bool
pointer then String
" -DGC_DEBUG " else String
"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool -> Bool
not Bool
genGC then String
" GC=nongen " else String
" GC=gen ")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
print_gc_stats then String
" GCSTATS=1 " else String
"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
pointer then String
" POINTER=1 " else String
"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
parallel then String
" PARALLEL=1 " else String
"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
bumpAlloc then String
" BUMPALLOC=1 " else String
"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
" USER_CFLAGS=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
" VERBOSITY=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
verbosity)
  Maybe String -> String -> String -> String -> IO ()
execCmd
    Maybe String
forall a. Maybe a
Nothing
    String
rtsmkcmd
    String
"Compiling RTS\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
    String
"codegen: C RTS could not be compiled: "
  where
    bumpAlloc :: Bool
bumpAlloc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BumpAlloc DynFlags
dynflags
    pointer :: Bool
pointer = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pointer DynFlags
dynflags
    warnc :: Bool
warnc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Warnc DynFlags
dynflags
    parallel :: Bool
parallel = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Parallel DynFlags
dynflags
    rts_debug :: Bool
rts_debug = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RtsDebug DynFlags
dynflags
    print_gc_stats :: Bool
print_gc_stats = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintGcStats DynFlags
dynflags
    genGC :: Bool
genGC = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenGc DynFlags
dynflags


-- | Compile and run the generated code if appropriate
--
compileAndRunExe :: Config -> FilePath -> IO String
compileAndRunExe :: Config -> String -> IO String
compileAndRunExe cfg :: Config
cfg@Config{Backend
backend :: Config -> Backend
backend :: Backend
backend,Maybe String
arrayInput :: Maybe String
arrayInput :: Config -> Maybe String
arrayInput,Maybe String
benchInput :: Maybe String
benchInput :: Config -> Maybe String
benchInput,Mode
mode :: Config -> Mode
mode :: Mode
mode,Maybe String
cfile :: Config -> Maybe String
cfile :: Maybe String
cfile,Maybe String
exefile :: Config -> Maybe String
exefile :: Maybe String
exefile} String
fp = do
  String
exepath <- String -> IO String
makeAbsolute String
exe
  String -> IO ()
clearFile String
exepath
  -- (Stage 4) Codegen finished, generate a binary
  IO ()
compile_program
  -- (Stage 5) Binary compiled, run if appropriate
  let runExe :: String -> IO String
runExe String
extra = do
        (Maybe Handle
_,Just Handle
hout,Maybe Handle
_, ProcessHandle
phandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> CreateProcess
shell (String
exepathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
extra))
                                      { std_out :: StdStream
std_out = StdStream
CreatePipe }
        ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
phandle
        case ExitCode
exitCode of
            ExitCode
ExitSuccess -> Handle -> IO String
hGetContents Handle
hout
            ExitFailure Int
n -> String -> IO String
forall a. String -> IO a
die(String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Treelang program exited with error code  "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
  RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig [] -- FIXME: no command line option atm.  Just env vars.
  case Maybe String
benchInput of
    -- CONVENTION: In benchmark mode we expect the generated executable to take 2 extra params:
    Just String
_ | Mode -> Bool
isBench Mode
mode   -> case Maybe String
arrayInput of
                                 Maybe String
Nothing -> String -> IO String
runExe (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RunConfig -> Int
rcSize RunConfig
runConf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (RunConfig -> Word64
rcIters RunConfig
runConf)
                                 Just String
fp -> String -> IO String
runExe (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"--array-input " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RunConfig -> Int
rcSize RunConfig
runConf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (RunConfig -> Word64
rcIters RunConfig
runConf)
    Maybe String
_      | Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
RunExe -> case Maybe String
arrayInput of
                                 Maybe String
Nothing -> String -> IO String
runExe String
""
                                 Just String
fp -> String -> IO String
runExe (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"--array-input " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
    Maybe String
_                                -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
  where outfile :: String
outfile = Backend -> String -> Maybe String -> String
getOutfile Backend
backend String
fp Maybe String
cfile
        exe :: String
exe = Backend -> String -> Maybe String -> String
getExeFile Backend
backend String
fp Maybe String
exefile
        pointer :: Bool
pointer = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pointer (Config -> DynFlags
dynflags Config
cfg)
        links :: String
links = if Bool
pointer
                then String
" -lgc -lm "
                else String
" -lm "
        compile_program :: IO ()
compile_program = do
            Config -> IO ()
compileRTS Config
cfg
            String
lib_dir <- IO String
getRTSBuildDir
            let rts_o_path :: String
rts_o_path = String
lib_dir String -> String -> String
</> String
"gibbon_rts.o"
            let compile_prog_cmd :: String
compile_prog_cmd = Backend -> Config -> String
compilationCmd Backend
backend Config
cfg
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -o " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exe
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib_dir
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib_dir
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -Wl,-rpath=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outfile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rts_o_path
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
links String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -lgibbon_rts_ng"

            Maybe String -> String -> String -> String -> IO ()
execCmd
              Maybe String
forall a. Maybe a
Nothing
              String
compile_prog_cmd
              String
"Compiling the program\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
              (Backend -> String
forall a. Show a => a -> String
show Backend
backend String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" compiler failed! ")
            () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getGibbonDir :: IO String
getGibbonDir :: IO String
getGibbonDir =
  do [(String, String)]
env <- IO [(String, String)]
getEnvironment
     String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"GIBBONDIR" [(String, String)]
env of
       Just String
p  -> String
p
       -- Otherwise, assume we're running from the compiler dir!
       Maybe String
Nothing -> String
"./"

getRTSBuildDir :: IO String
getRTSBuildDir :: IO String
getRTSBuildDir =
  do String
gibbon_dir <- IO String
getGibbonDir
     let build_dir :: String
build_dir = String
gibbon_dir String -> String -> String
</> String
"gibbon-rts/build"
     Bool
exists <- String -> IO Bool
doesDirectoryExist String
build_dir
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (String -> IO ()
forall a. HasCallStack => String -> a
error String
"RTS build not found.")
     String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
build_dir


execCmd :: Maybe FilePath -> String -> String -> String -> IO ()
execCmd :: Maybe String -> String -> String -> String -> IO ()
execCmd Maybe String
dir String
cmd String
msg String
errmsg = do
    Int -> String -> IO ()
dbgPrintLn Int
2 String
msg
    Int -> String -> IO ()
dbgPrintLn Int
2 String
cmd
    (Maybe Handle
_,Just Handle
hout,Just Handle
herr,ProcessHandle
phandle) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> CreateProcess
shell String
cmd)
            { std_out :: StdStream
std_out = StdStream
CreatePipe
            , std_err :: StdStream
std_err = StdStream
CreatePipe
            , cwd :: Maybe String
cwd     = Maybe String
dir
            }
    ExitCode
exit_code <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
phandle
    case ExitCode
exit_code of
        ExitCode
ExitSuccess -> do String
out <- Handle -> IO String
hGetContents Handle
hout
                          String
err <- Handle -> IO String
hGetContents Handle
herr
                          Int -> String -> IO ()
dbgPrintLn Int
2 String
out
                          Int -> String -> IO ()
dbgPrintLn Int
2 String
err
        ExitFailure Int
n -> do String
out <- Handle -> IO String
hGetContents Handle
hout
                            String
err <- Handle -> IO String
hGetContents Handle
herr
                            String -> IO ()
forall a. String -> IO a
die(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
errmsgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
outString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
errString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nCode: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n



-- | Return the correct filename to store the generated code,
-- based on the backend used, and override options specified
--
getOutfile :: Backend -> FilePath -> Maybe FilePath -> FilePath
getOutfile :: Backend -> String -> Maybe String -> String
getOutfile Backend
_ String
_ (Just String
override) = String
override
getOutfile Backend
backend String
fp Maybe String
Nothing =
  String -> String -> String
replaceExtension String
fp (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    case Backend
backend of
      Backend
C    -> String
".c"
      Backend
LLVM -> String
".ll"

-- | Return the correct filename for the generated exe,
-- based on the backend used, and override options specified
--
getExeFile :: Backend -> FilePath -> Maybe FilePath -> FilePath
getExeFile :: Backend -> String -> Maybe String -> String
getExeFile Backend
_ String
_ (Just String
override) = String
override
getExeFile Backend
backend String
fp Maybe String
Nothing =
  let fp' :: String
fp' = case Backend
backend of
               Backend
C -> String
fp
               Backend
LLVM -> String -> String -> String
replaceFileName String
fp (String -> String
takeBaseName String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_llvm")
  in String -> String -> String
replaceExtension String
fp' String
".exe"

-- | Compilation command
--
compilationCmd :: Backend -> Config -> String
compilationCmd :: Backend -> Config -> String
compilationCmd Backend
LLVM Config
_   = String
"clang-5.0 lib.o "
compilationCmd Backend
C Config
config = (Config -> String
cc Config
config) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -std=gnu11 "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++(if Bool
bumpAlloc then String
" -D_GIBBON_BUMPALLOC_LISTS -D_GIBBON_BUMPALLOC_HEAP " else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++(if Bool
pointer then String
" -D_GIBBON_POINTER " else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++(if Bool
parallel then String
" -fcilkplus -D_GIBBON_PARALLEL " else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++(if Bool
warnc
                             then String
" -Wno-unused-variable -Wno-unused-label -Wall -Wextra -Wpedantic "
                             else String
suppress_warnings)
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Config -> String
optc Config
config)
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
rts_debug then String
" -D_GIBBON_DEBUG -D_GIBBON_VERBOSITY=3 -O0 -g" else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
rts_debug Bool -> Bool -> Bool
&& Bool
pointer then String
" -DGC_DEBUG " else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
print_gc_stats then String
" -D_GIBBON_GCSTATS " else String
"")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool -> Bool
not Bool
genGC then String
" -D_GIBBON_GENGC=0 " else String
" -D_GIBBON_GENGC=1 ")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
simpleWriteBarrier then String
" -D_GIBBON_SIMPLE_WRITE_BARRIER=1 " else String
" -D_GIBBON_SIMPLE_WRITE_BARRIER=0 ")
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
lazyPromote then String
" -D_GIBBON_EAGER_PROMOTION=0 " else String
" -D_GIBBON_EAGER_PROMOTION=1 ")
  where dflags :: DynFlags
dflags = Config -> DynFlags
dynflags Config
config
        bumpAlloc :: Bool
bumpAlloc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BumpAlloc DynFlags
dflags
        pointer :: Bool
pointer = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pointer DynFlags
dflags
        warnc :: Bool
warnc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Warnc DynFlags
dflags
        parallel :: Bool
parallel = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Parallel DynFlags
dflags
        rts_debug :: Bool
rts_debug = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RtsDebug DynFlags
dflags
        print_gc_stats :: Bool
print_gc_stats = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintGcStats DynFlags
dflags
        genGC :: Bool
genGC = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenGc DynFlags
dflags
        simpleWriteBarrier :: Bool
simpleWriteBarrier = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimpleWriteBarrier DynFlags
dflags
        lazyPromote :: Bool
lazyPromote = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoEagerPromote DynFlags
dflags

-- |
isBench :: Mode -> Bool
isBench :: Mode -> Bool
isBench (Bench Var
_) = Bool
True
isBench Mode
_ = Bool
False

-- | The debug level at which we start to call the interpreter on the program during compilation.
interpDbgLevel :: Int
interpDbgLevel :: Int
interpDbgLevel = Int
5

-- |
clearFile :: FilePath -> IO ()
clearFile :: String -> IO ()
clearFile String
fileName = String -> IO ()
removeFile String
fileName IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO ()
handleErr
  where
   handleErr :: IOError -> IO ()
handleErr IOError
e | IOError -> Bool
isDoesNotExistError IOError
e = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               | Bool
otherwise = IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e

--------------------------------------------------------------------------------

-- | SML Codegen

mplCompiler :: String
mplCompiler :: String
mplCompiler = String
"mlton"  -- temporary until mpl is installed

goIO :: Functor m => a1 -> m a2 -> StateT b m a1
goIO :: forall (m :: * -> *) a1 a2 b.
Functor m =>
a1 -> m a2 -> StateT b m a1
goIO a1
prog m a2
io = (b -> m (a1, b)) -> StateT b m a1
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((b -> m (a1, b)) -> StateT b m a1)
-> (b -> m (a1, b)) -> StateT b m a1
forall a b. (a -> b) -> a -> b
$ \b
x -> m a2
io m a2 -> (a1, b) -> m (a1, b)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (a1
prog, b
x)

smlExt :: FilePath -> FilePath
smlExt :: String -> String
smlExt String
fp = String -> String
dropExtension String
fp String -> String -> String
<.> String
"sml"

toSML :: FilePath -> L1.Prog1 -> IO ()
toSML :: String -> Prog1 -> IO ()
toSML String
fp Prog1
prog = String -> String -> IO ()
writeFile (String -> String
smlExt String
fp) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Prog1 -> Doc
ppProgram Prog1
prog

compileMPL :: FilePath -> IO ()
compileMPL :: String -> IO ()
compileMPL String
fp = do
  ExitCode
cd <- String -> IO ExitCode
system (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
mplCompiler String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
smlExt String
fp
  case ExitCode
cd of
    ExitFailure Int
n -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SML compiler failed with code " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
    ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runMPL :: FilePath -> IO ()
runMPL :: String -> IO ()
runMPL String
fp = do
  ExitCode
cd <- String -> IO ExitCode
system (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
dropExtension String
fp
  case ExitCode
cd of
    ExitFailure Int
n -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SML executable failed with code " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
    ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    prefix :: String
prefix = case String -> String
takeDirectory String
fp of
      String
"" -> String
"./"
      String
_ -> String
""

goSML :: Config -> L1.Prog1 -> (FilePath -> IO a2) -> StateT b IO L1.Prog1
goSML :: forall a2 b.
Config -> Prog1 -> (String -> IO a2) -> StateT b IO Prog1
goSML Config
config Prog1
prog String -> IO a2
acts = 
  Prog1 -> IO a2 -> StateT b IO Prog1
forall (m :: * -> *) a1 a2 b.
Functor m =>
a1 -> m a2 -> StateT b m a1
goIO Prog1
prog (String -> Prog1 -> IO ()
toSML String
fp Prog1
prog IO () -> IO a2 -> IO a2
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> IO a2
acts String
fp)
  where Just String
fp = Config -> Maybe String
srcFile Config
config

--------------------------------------------------------------------------------

-- | Replace the main function with benchmark code
--
benchMainExp :: L1.Prog1 -> PassM L1.Prog1
benchMainExp :: Prog1 -> PassM Prog1
benchMainExp Prog1
l1 = do
  Config{Maybe String
benchInput :: Config -> Maybe String
benchInput :: Maybe String
benchInput,DynFlags
dynflags :: Config -> DynFlags
dynflags :: DynFlags
dynflags,Mode
mode :: Config -> Mode
mode :: Mode
mode} <- PassM Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Mode
mode of
    Bench Var
fnname -> do
      let tmp :: String
tmp = String
"bnch"
          ([arg :: Ty1
arg@(L1.PackedTy String
tyc ()
_)], Ty1
ret) = Var -> Prog1 -> ArrowTy (TyOf Exp1)
forall ex. Var -> Prog ex -> ArrowTy (TyOf ex)
L1.getFunTy Var
fnname Prog1
l1
          -- At L1, we assume ReadPackedFile has a single return value:
          newExp :: Exp1
newExp = Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
L1.TimeIt (
                        (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (String -> Var
toVar String
tmp, [],
                                 Ty1
arg,
                                 Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L1.PrimAppE
                                 (Maybe String -> String -> Maybe Var -> Ty1 -> Prim Ty1
forall ty. Maybe String -> String -> Maybe Var -> ty -> Prim ty
L1.ReadPackedFile Maybe String
benchInput String
tyc Maybe Var
forall a. Maybe a
Nothing Ty1
arg) [])
                        (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (String -> Var
toVar String
"benchres", [],
                                      Ty1
ret,
                                      Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
L1.AppE Var
fnname [] [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L1.VarE (String -> Var
toVar String
tmp)])
                        -- FIXME: should actually return the result,
                        -- as soon as we are able to print it.
                        (if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BenchPrint DynFlags
dynflags
                         then Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L1.VarE (String -> Var
toVar String
"benchres")
                         else Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L1.PrimAppE Prim Ty1
forall ty. Prim ty
L1.MkTrue [])
                   ) Ty1
ret Bool
True
      -- Initialize the main expression with a void type. The typechecker will fix it later.
      Prog1 -> PassM Prog1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog1 -> PassM Prog1) -> Prog1 -> PassM Prog1
forall a b. (a -> b) -> a -> b
$ Prog1
l1{ mainExp :: Maybe (Exp1, TyOf Exp1)
L1.mainExp = (Exp1, Ty1) -> Maybe (Exp1, Ty1)
forall a. a -> Maybe a
Just (Exp1
newExp, Ty1
forall a. UrTy a
L1.voidTy) }
    Mode
_ -> Prog1 -> PassM Prog1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog1
l1

addRedirectionCon :: L2.Prog2 -> PassM L2.Prog2
addRedirectionCon :: Prog2 -> PassM Prog2
addRedirectionCon p :: Prog2
p@Prog{DDefs (TyOf Exp2)
ddefs :: DDefs (TyOf Exp2)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs} = do
  Map Var (DDef (UrTy Var))
ddefs' <- (DDef (UrTy Var) -> PassM (DDef (UrTy Var)))
-> Map Var (DDef (UrTy Var)) -> PassM (Map Var (DDef (UrTy Var)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM (\ddf :: DDef (UrTy Var)
ddf@DDef{[(String, [(Bool, UrTy Var)])]
dataCons :: [(String, [(Bool, UrTy Var)])]
dataCons :: forall a. DDef a -> [(String, [(Bool, a)])]
dataCons} -> do
                    String
dcon <- Var -> String
fromVar (Var -> String) -> PassM Var -> PassM String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
redirectionTag)
                    let datacons :: [(String, [(Bool, UrTy Var)])]
datacons = ((String, [(Bool, UrTy Var)]) -> Bool)
-> [(String, [(Bool, UrTy Var)])] -> [(String, [(Bool, UrTy Var)])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, [(Bool, UrTy Var)]) -> Bool)
-> (String, [(Bool, UrTy Var)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isRedirectionTag (String -> Bool)
-> ((String, [(Bool, UrTy Var)]) -> String)
-> (String, [(Bool, UrTy Var)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [(Bool, UrTy Var)]) -> String
forall a b. (a, b) -> a
fst) [(String, [(Bool, UrTy Var)])]
dataCons
                    DDef (UrTy Var) -> PassM (DDef (UrTy Var))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return DDef (UrTy Var)
ddf {dataCons :: [(String, [(Bool, UrTy Var)])]
dataCons = [(String, [(Bool, UrTy Var)])]
datacons [(String, [(Bool, UrTy Var)])]
-> [(String, [(Bool, UrTy Var)])] -> [(String, [(Bool, UrTy Var)])]
forall a. [a] -> [a] -> [a]
++ [(String
dcon, [(Bool
False, UrTy Var
forall a. UrTy a
CursorTy)])]})
            DDefs (TyOf Exp2)
Map Var (DDef (UrTy Var))
ddefs
  Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog2 -> PassM Prog2) -> Prog2 -> PassM Prog2
forall a b. (a -> b) -> a -> b
$ Prog2
p { ddefs :: DDefs (TyOf Exp2)
ddefs = DDefs (TyOf Exp2)
Map Var (DDef (UrTy Var))
ddefs' }

-- | The main compiler pipeline
passes :: (Show v) => Config -> L0.Prog0 -> StateT (CompileState v) IO L4.Prog
passes :: forall v.
Show v =>
Config -> Prog0 -> StateT (CompileState v) IO Prog
passes config :: Config
config@Config{DynFlags
dynflags :: Config -> DynFlags
dynflags :: DynFlags
dynflags} Prog0
l0 = do
      let isPacked :: Bool
isPacked   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Packed DynFlags
dynflags
          biginf :: Bool
biginf     = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BigInfiniteRegions DynFlags
dynflags
          gibbon1 :: Bool
gibbon1    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Gibbon1 DynFlags
dynflags
          no_rcopies :: Bool
no_rcopies = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_No_RemoveCopies DynFlags
dynflags
          parallel :: Bool
parallel   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Parallel DynFlags
dynflags
          should_fuse :: Bool
should_fuse = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Fusion DynFlags
dynflags
          tcProg3 :: Prog3 -> PassM Prog3
tcProg3     = Bool -> Prog3 -> PassM Prog3
L3.tcProg Bool
isPacked
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall a b v. PassRunner a b v
go  String
"freshen"         Prog0 -> PassM Prog0
freshNames            Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"typecheck"       Prog0 -> PassM Prog0
L0.tcProg             Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall a b v. PassRunner a b v
go  String
"elimNewtypes"     Prog0 -> PassM Prog0
forall (m :: * -> *). Monad m => Prog0 -> m Prog0
L0.elimNewtypes            Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"typecheck"       Prog0 -> PassM Prog0
L0.tcProg             Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"bindLambdas"     Prog0 -> PassM Prog0
L0.bindLambdas       Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"monomorphize"    Prog0 -> PassM Prog0
L0.monomorphize      Prog0
l0
      -- l0 <- goE0 "closureConvert"  L0.closureConvert    l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"specLambdas"     Prog0 -> PassM Prog0
L0.specLambdas       Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"desugarL0"       Prog0 -> PassM Prog0
L0.desugarL0         Prog0
l0
      Prog0
l0 <- String
-> (Prog0 -> PassM Prog0)
-> Prog0
-> StateT (CompileState v) IO Prog0
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"floatOutCase"    Prog0 -> PassM Prog0
L0.floatOutCase      Prog0
l0
      -- Note: L0 -> L1
      Prog1
l1 <- String
-> (Prog0 -> PassM Prog1)
-> Prog0
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"toL1"            (Prog1 -> PassM Prog1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog1 -> PassM Prog1) -> (Prog0 -> Prog1) -> Prog0 -> PassM Prog1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog0 -> Prog1
L0.toL1)     Prog0
l0

      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"typecheck"     Prog1 -> PassM Prog1
L1.tcProg              Prog1
l1
      -- If we are executing a benchmark, then we
      -- replace the main function with benchmark code:
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"benchMainExp"  Prog1 -> PassM Prog1
benchMainExp           Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"typecheck"     Prog1 -> PassM Prog1
L1.tcProg              Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"simplify"      Prog1 -> PassM Prog1
simplifyL1             Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"typecheck"     Prog1 -> PassM Prog1
L1.tcProg              Prog1
l1
      -- Check this after eliminating all dead functions.
      Bool
-> StateT (CompileState v) IO () -> StateT (CompileState v) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Prog1 -> Bool
forall (e :: * -> * -> *) l d. Prog (PreExp e l d) -> Bool
hasSpawnsProg Prog1
l1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
parallel) (StateT (CompileState v) IO () -> StateT (CompileState v) IO ())
-> StateT (CompileState v) IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$
        String -> StateT (CompileState v) IO ()
forall a. HasCallStack => String -> a
error String
"To compile a program with parallelism, use --parallel."
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"flatten"       Prog1 -> PassM Prog1
flattenL1              Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"simplify"      Prog1 -> PassM Prog1
simplifyL1             Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"inlineTriv"    Prog1 -> PassM Prog1
forall (e :: * -> * -> *) l d.
HasSimplifiable e l d =>
Prog (PreExp e l d) -> PassM (Prog (PreExp e l d))
inlineTriv             Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"typecheck"     Prog1 -> PassM Prog1
L1.tcProg              Prog1
l1
      Prog1
l1 <- if Bool
should_fuse
          then String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1  String
"fusion2"   Prog1 -> PassM Prog1
fusion2                Prog1
l1
          else Prog1 -> StateT (CompileState v) IO Prog1
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog1
l1
      Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 String
"typecheck"     Prog1 -> PassM Prog1
L1.tcProg              Prog1
l1

      -- Minimal haskell "backend".
      IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Config -> DebugFlag -> String -> IO ()
dumpIfSet Config
config DebugFlag
Opt_D_Dump_Hs (Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Prog1 -> Doc
pprintHsWithEnv Prog1
l1)

      Prog1
l1 <- case Config -> Mode
mode Config
config of
        Mode
ToMPL -> Config
-> Prog1 -> (String -> IO ()) -> StateT (CompileState v) IO Prog1
forall a2 b.
Config -> Prog1 -> (String -> IO a2) -> StateT b IO Prog1
goSML Config
config Prog1
l1 (IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Mode
ToMPLExe -> Config
-> Prog1 -> (String -> IO ()) -> StateT (CompileState v) IO Prog1
forall a2 b.
Config -> Prog1 -> (String -> IO a2) -> StateT b IO Prog1
goSML Config
config Prog1
l1 String -> IO ()
compileMPL
        Mode
RunMPL -> Config
-> Prog1 -> (String -> IO ()) -> StateT (CompileState v) IO Prog1
forall a2 b.
Config -> Prog1 -> (String -> IO a2) -> StateT b IO Prog1
goSML Config
config Prog1
l1 (\String
fp -> String -> IO ()
compileMPL String
fp IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> IO ()
runMPL String
fp)
        Mode
_ -> Prog1 -> StateT (CompileState v) IO Prog1
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog1
l1

      -- -- TODO: Write interpreters for L2 and L3
      Prog3
l3 <- if Bool
isPacked
            then do
              -- TODO: push data contstructors under conditional
              -- branches before InferLocations.

              -- Note: L1 -> L2
              -- l1 <- goE1 "copyOutOfOrderPacked" copyOutOfOrderPacked l1
              Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall a b v. PassRunner a b v
go String
"L1.typecheck"    Prog1 -> PassM Prog1
L1.tcProg     Prog1
l1
              Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"removeCopyAliases" Prog1 -> PassM Prog1
removeAliasesForCopyCalls Prog1
l1
              Prog2
l2 <- String
-> (Prog1 -> PassM Prog2)
-> Prog1
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"inferLocations"  Prog1 -> PassM Prog2
inferLocs    Prog1
l1
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"simplifyLocBinds_a" (Bool -> Prog2 -> PassM Prog2
simplifyLocBinds Bool
True) Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg    Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"regionsInwards"    Prog2 -> PassM Prog2
regionsInwards Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg    Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"simplifyLocBinds" (Bool -> Prog2 -> PassM Prog2
simplifyLocBinds Bool
True) Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"fixRANs"         Prog2 -> PassM Prog2
fixRANs      Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg    Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"L2.flatten"      Flattenable (E2Ext Var (UrTy Var)) => Prog2 -> PassM Prog2
Prog2 -> PassM Prog2
flattenL2    Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg    Prog2
l2
              Prog2
l2 <- if Bool
gibbon1 Bool -> Bool -> Bool
|| Bool
no_rcopies
                    then Prog2 -> StateT (CompileState v) IO Prog2
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog2
l2
                    else do Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"removeCopies" Prog2 -> PassM Prog2
removeCopies Prog2
l2
                            String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"       Prog2 -> PassM Prog2
L2.tcProg    Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"inferEffects" Prog2 -> PassM Prog2
inferEffects  Prog2
l2

{- Note [Repairing programs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We need a program analysis that decides whether a L2 program needs to be repaired.
Why ? Because, when we pattern match on a packed value, L2 assumes that *every*
variable in that pattern is accessible. However, this is not always true.
Consider the rightmost fn (which does not traverse it's input):

   (Node [(x, loc_x), (y, loc_y)] BODY)

Here, since the input is not traversed, we won't have an end-witness for x. And we
cannot access y without it. We need to fix such programs. Effectively, what we're
looking for in this analyis is if we can unpack all the pattern matched variables
in case expressions occurring in the program. For functions, it means that either
the function should traverse it's input, or the un-reachable elements in the pattern
match must remain unused (eg. 'leftmost'). On the other hand, we always have to
repair a broken main expression (since the "unused" case won't apply).

The compiler has access to 2 program repair strategies -- dummy traversals or
random access nodes. If we're operating in gibbon1 mode, it uses the former. However,
this changes the asymptotic complexity of the functions. In gibbon2 mode, we compile
such programs to store RAN's instead. This basically allows O(1) access to any element
of a data constructor.

Also see Note [Adding dummy traversals] and Note [Adding random access nodes].

-}
              Prog2
l2 <-
                if Bool
gibbon1
                then do
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"addTraversals" Prog2 -> PassM Prog2
addTraversals Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"inferEffects2"  Prog2 -> PassM Prog2
inferEffects Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"repairProgram"  (Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog2 -> PassM Prog2) -> (Prog2 -> Prog2) -> Prog2 -> PassM Prog2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog2 -> Prog2
forall a. a -> a
id)  Prog2
l2
                  Prog2 -> StateT (CompileState v) IO Prog2
forall a. a -> StateT (CompileState v) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog2
l2
                else do
                  let need :: Set String
need = Prog2 -> Set String
needsRAN Prog2
l2
                  Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 String
"addRAN"        (Set String -> Prog1 -> PassM Prog1
addRAN Set String
need) Prog1
l1
                  Prog1
l1 <- String
-> (Prog1 -> PassM Prog1)
-> Prog1
-> StateT (CompileState v) IO Prog1
forall a b v. PassRunner a b v
go String
"L1.typecheck"    Prog1 -> PassM Prog1
L1.tcProg     Prog1
l1
                  -- NOTE: Calling copyOutOfOrderPacked here seems redundant since all the copy calls seem be exists in the correct place.
                  -- In addititon, calling it here gives a compile time error.
                  -- l1 <- goE1 "copyOutOfOrderPacked" copyOutOfOrderPacked l1
                  -- l1 <- go "L1.typecheck"    L1.tcProg     l1
                  Prog2
l2 <- String
-> (Prog1 -> PassM Prog2)
-> Prog1
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"inferLocations2" Prog1 -> PassM Prog2
inferLocs     Prog1
l1
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"simplifyLocBinds" (Bool -> Prog2 -> PassM Prog2
simplifyLocBinds Bool
True) Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"fixRANs"         Prog2 -> PassM Prog2
fixRANs       Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"  Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"regionsInwards" Prog2 -> PassM Prog2
regionsInwards Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go   String
"L2.typecheck"  Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.flatten"      Flattenable (E2Ext Var (UrTy Var)) => Prog2 -> PassM Prog2
Prog2 -> PassM Prog2
flattenL2     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"findWitnesses" Prog2 -> PassM Prog2
findWitnesses   Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"L2.flatten"    Flattenable (E2Ext Var (UrTy Var)) => Prog2 -> PassM Prog2
Prog2 -> PassM Prog2
flattenL2     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"removeCopies"  Prog2 -> PassM Prog2
removeCopies  Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"inferEffects2" Prog2 -> PassM Prog2
inferEffects  Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"addTraversals" Prog2 -> PassM Prog2
addTraversals Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"    Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
                  Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"repairProgram" (Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog2 -> PassM Prog2) -> (Prog2 -> Prog2) -> Prog2 -> PassM Prog2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog2 -> Prog2
forall a. a -> a
id)   Prog2
l2
                  Prog2 -> StateT (CompileState v) IO Prog2
forall a. a -> StateT (CompileState v) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog2
l2

              IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Config -> DebugFlag -> String -> IO ()
dumpIfSet Config
config DebugFlag
Opt_D_Dump_Repair (Prog2 -> String
forall e. Pretty e => e -> String
pprender Prog2
l2)
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"parAlloc"   Prog2 -> PassM Prog2
parAlloc  Prog2
l2
              IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Config -> DebugFlag -> String -> IO ()
dumpIfSet Config
config DebugFlag
Opt_D_Dump_ParAlloc (Prog2 -> String
forall e. Pretty e => e -> String
pprender Prog2
l2)
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck" Prog2 -> PassM Prog2
L2.tcProg Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"inferRegScope"  Prog2 -> PassM Prog2
inferRegScope Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"simplifyLocBinds" (Bool -> Prog2 -> PassM Prog2
simplifyLocBinds Bool
True) Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"writeOrderMarkers" Prog2 -> PassM Prog2
writeOrderMarkers Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"routeEnds"      Prog2 -> PassM Prog2
routeEnds     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"inferFunAllocs"   Prog2 -> PassM Prog2
inferFunAllocs Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"L2.typecheck"     Prog2 -> PassM Prog2
L2.tcProg     Prog2
l2
              -- L2 program no longer typechecks while these next passes run
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 String
"simplifyLocBinds" (Bool -> Prog2 -> PassM Prog2
simplifyLocBinds Bool
False) Prog2
l2
              Prog2
l2 <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"addRedirectionCon" Prog2 -> PassM Prog2
addRedirectionCon Prog2
l2
              -- l2 <- if gibbon1
              --       then pure l2
              --       else go "inferRegSize" inferRegSize l2
              Prog2
l2 <- if Bool
gibbon1
                    then Prog2 -> StateT (CompileState v) IO Prog2
forall a. a -> StateT (CompileState v) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog2
l2
                    else String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"followPtrs" Prog2 -> PassM Prog2
followPtrs Prog2
l2
              Prog2
l2' <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"fromOldL2" Prog2 -> PassM Prog2
fromOldL2 Prog2
l2

              -- N.B ThreadRegions doesn't produce a type-correct L2 program --
              -- it adds regions to 'locs' in AppE and LetE which the
              -- typechecker doesn't know how to handle.
              Prog2
l2' <- String
-> (Prog2 -> PassM Prog2)
-> Prog2
-> StateT (CompileState v) IO Prog2
forall a b v. PassRunner a b v
go String
"threadRegions"    Prog2 -> PassM Prog2
threadRegions Prog2
l2'

              -- L2 -> L3
              -- TODO: Compose L3.TcM with (ReaderT Config)
              Prog3
l3 <- String
-> (Prog2 -> PassM Prog3)
-> Prog2
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"cursorize"        Prog2 -> PassM Prog3
cursorize     Prog2
l2'
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"reorderScalarWrites" Prog3 -> PassM Prog3
reorderScalarWrites  Prog3
l3
              -- _ <- lift $ putStrLn (pprender l3)
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.flatten"       Prog3 -> PassM Prog3
flattenL3     Prog3
l3
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.typecheck"     Prog3 -> PassM Prog3
tcProg3       Prog3
l3
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"hoistNewBuf"      Prog3 -> PassM Prog3
hoistNewBuf   Prog3
l3
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.typecheck"     Prog3 -> PassM Prog3
tcProg3       Prog3
l3
              Prog3 -> StateT (CompileState v) IO Prog3
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog3
l3
            else do
              Prog3
l3 <- String
-> (Prog1 -> PassM Prog3)
-> Prog1
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"directL3"         Prog1 -> PassM Prog3
directL3      Prog1
l1
              Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.typecheck"     Prog3 -> PassM Prog3
tcProg3       Prog3
l3
              Prog3 -> StateT (CompileState v) IO Prog3
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog3
l3

      Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"unariser"       Prog3 -> PassM Prog3
unariser                Prog3
l3
      Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.typecheck"   Prog3 -> PassM Prog3
tcProg3                 Prog3
l3
      Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.flatten"     Prog3 -> PassM Prog3
flattenL3               Prog3
l3
      Prog3
l3 <- String
-> (Prog3 -> PassM Prog3)
-> Prog3
-> StateT (CompileState v) IO Prog3
forall a b v. PassRunner a b v
go String
"L3.typecheck"   Prog3 -> PassM Prog3
tcProg3                 Prog3
l3

      -- Note: L3 -> L4
      Prog
l4 <- String
-> (Prog3 -> PassM Prog)
-> Prog3
-> StateT (CompileState v) IO Prog
forall a b v. PassRunner a b v
go String
"lower"          Prog3 -> PassM Prog
lower                   Prog3
l3
      Prog
l4 <- String
-> (Prog -> PassM Prog) -> Prog -> StateT (CompileState v) IO Prog
forall a b v. PassRunner a b v
go String
"lateInlineTriv" Prog -> PassM Prog
lateInlineTriv          Prog
l4
      Prog
l4 <- if Bool
gibbon1 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isPacked
            then do
              Prog
l4 <- String
-> (Prog -> PassM Prog) -> Prog -> StateT (CompileState v) IO Prog
forall a b v. PassRunner a b v
go String
"rearrangeFree"  Prog -> PassM Prog
rearrangeFree   Prog
l4
              Prog -> StateT (CompileState v) IO Prog
forall a. a -> StateT (CompileState v) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog
l4
            else do
              Prog
l4 <- String
-> (Prog -> PassM Prog) -> Prog -> StateT (CompileState v) IO Prog
forall a b v. PassRunner a b v
go String
"rearrangeFree"   Prog -> PassM Prog
rearrangeFree   Prog
l4
              -- l4 <- go "inlineTrivL4"    (pure . L4.inlineTrivL4) l4
              Prog -> StateT (CompileState v) IO Prog
forall a. a -> StateT (CompileState v) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog
l4
      Prog -> StateT (CompileState v) IO Prog
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog
l4
  where
      go :: PassRunner a b v
      go :: forall a b v. PassRunner a b v
go = Config -> PassRunner a b v
forall a b v. Config -> PassRunner a b v
pass Config
config

      goE2 :: (InterpProg Store b, Show v) => InterpPassRunner a b Store v
      goE2 :: forall b v a.
(InterpProg Store b, Show v) =>
InterpPassRunner a b Store v
goE2 = Store -> Config -> InterpPassRunner a b Store v
forall s p2 v p1.
(InterpProg s p2, Show v) =>
s -> Config -> InterpPassRunner p1 p2 s v
passE Store
emptyStore Config
config

      goE0 :: (InterpProg () b, Show v) => InterpPassRunner a b () v
      goE0 :: forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE0 = () -> Config -> InterpPassRunner a b () v
forall s p2 v p1.
(InterpProg s p2, Show v) =>
s -> Config -> InterpPassRunner p1 p2 s v
passE () Config
config

      goE1 :: (InterpProg () b, Show v) => InterpPassRunner a b () v
      goE1 :: forall b v a.
(InterpProg () b, Show v) =>
InterpPassRunner a b () v
goE1 = () -> Config -> InterpPassRunner a b () v
forall s p2 v p1.
(InterpProg s p2, Show v) =>
s -> Config -> InterpPassRunner p1 p2 s v
passE () Config
config

type PassRunner a b v = (Pretty b, Out b, NFData a, NFData b) =>
                         String -> (a -> PassM b) -> a -> StateT (CompileState v) IO b

type InterpPassRunner a b s v = (HasPretty a, HasPretty b, HasOut a, HasOut b,
                                HasGeneric a, HasGeneric b, HasNFData a, HasNFData b) =>
                                String -> (Prog a -> PassM (Prog b)) -> Prog a -> StateT (CompileState v) IO (Prog b)

-- | Run a pass and return the result
--
pass :: Config -> PassRunner a b v
pass :: forall a b v. Config -> PassRunner a b v
pass Config
config String
who a -> PassM b
fn a
x = do
  cs :: CompileState v
cs@CompileState{Int
cnt :: forall a. CompileState a -> Int
cnt :: Int
cnt} <- StateT (CompileState v) IO (CompileState v)
forall s (m :: * -> *). MonadState s m => m s
get
  a
x' <- if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
passChatterLvl
        then IO a -> StateT (CompileState v) IO a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> StateT (CompileState v) IO a)
-> IO a -> StateT (CompileState v) IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. NFData a => a -> a
force a
x
        else a -> StateT (CompileState v) IO a
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> IO ()
dbgPrint Int
passChatterLvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" [compiler] Running pass, " String -> String -> String
forall a. [a] -> [a] -> [a]
++String
who

  let (b
y,Int
cnt') = Config -> Int -> PassM b -> (b, Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
config Int
cnt (a -> PassM b
fn a
x')
  CompileState v -> StateT (CompileState v) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put CompileState v
cs{cnt :: Int
cnt=Int
cnt'}
  b
y' <- if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
passChatterLvl
        then IO b -> StateT (CompileState v) IO b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO b -> StateT (CompileState v) IO b)
-> IO b -> StateT (CompileState v) IO b
forall a b. (a -> b) -> a -> b
$ b -> IO b
forall a. a -> IO a
evaluate (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ b -> b
forall a. NFData a => a -> a
force b
y
        else b -> StateT (CompileState v) IO b
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
y
  if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
passChatterLvlInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
     then IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> IO ()
dbgPrintLn (Int
passChatterLvlInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Pass output:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
seplineString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++ (b -> String
forall e. Pretty e => e -> String
pprender b
y')
     -- TODO: Switch to a node-count for size output (add to GenericOps):
     else IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> IO ()
dbgPrintLn Int
passChatterLvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"   => "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (b -> String
forall a. Out a => a -> String
sdoc b
y')) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" characters output."
  b -> StateT (CompileState v) IO b
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
y'


passChatterLvl :: Int
passChatterLvl :: Int
passChatterLvl = Int
3


-- | Like 'pass', but also evaluates and checks the result.
--
passE :: (InterpProg s p2, Show v) => s -> Config -> InterpPassRunner p1 p2 s v
passE :: forall s p2 v p1.
(InterpProg s p2, Show v) =>
s -> Config -> InterpPassRunner p1 p2 s v
passE s
s config :: Config
config@Config{Mode
mode :: Config -> Mode
mode :: Mode
mode} = s
-> Mode -> InterpPassRunner p1 p2 s v -> InterpPassRunner p1 p2 s v
forall s b v a.
(InterpProg s b, Show v) =>
s -> Mode -> InterpPassRunner a b s v -> InterpPassRunner a b s v
wrapInterp s
s Mode
mode (Config -> PassRunner (Prog p1) (Prog p2) v
forall a b v. Config -> PassRunner a b v
pass Config
config)


-- | An alternative version that allows FAILURE while running
-- the interpreter part.
-- FINISHME! For now not interpreting.
--
passF :: Config -> PassRunner p1 p2 v
passF :: forall a b v. Config -> PassRunner a b v
passF = Config
-> String
-> (p1 -> PassM p2)
-> p1
-> StateT (CompileState v) IO p2
Config -> PassRunner p1 p2 v
forall a b v. Config -> PassRunner a b v
pass


-- | Wrapper to enable running a pass AND interpreting the result.
--
wrapInterp :: (InterpProg s b, Show v)
           => s -> Mode -> InterpPassRunner a b s v -> InterpPassRunner a b s v
wrapInterp :: forall s b v a.
(InterpProg s b, Show v) =>
s -> Mode -> InterpPassRunner a b s v -> InterpPassRunner a b s v
wrapInterp s
s Mode
mode InterpPassRunner a b s v
pass String
who Prog a -> PassM (Prog b)
fn Prog a
x =
  do CompileState{Maybe (Value v)
result :: forall a. CompileState a -> Maybe (Value a)
result :: Maybe (Value v)
result} <- StateT (CompileState v) IO (CompileState v)
forall s (m :: * -> *). MonadState s m => m s
get
     Prog b
p2 <- String
-> (Prog a -> PassM (Prog b))
-> Prog a
-> StateT (CompileState v) IO (Prog b)
InterpPassRunner a b s v
pass String
who Prog a -> PassM (Prog b)
fn Prog a
x
     -- In benchmark mode we simply turn OFF the interpreter.
     -- This decision should be finer grained.
     Bool
-> StateT (CompileState v) IO () -> StateT (CompileState v) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
interpDbgLevel Bool -> Bool -> Bool
&& Bool -> Bool
not (Mode -> Bool
isBench Mode
mode)) (StateT (CompileState v) IO () -> StateT (CompileState v) IO ())
-> StateT (CompileState v) IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT (CompileState v) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (CompileState v) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (CompileState v) IO ())
-> IO () -> StateT (CompileState v) IO ()
forall a b. (a -> b) -> a -> b
$ do
       let Just Value v
res1 = Maybe (Value v)
result
       -- FIXME: no command line option atm.  Just env vars.
       RunConfig
runConf <- [String] -> IO RunConfig
getRunConfig []
       let res2 :: String
res2 = s -> RunConfig -> Prog b -> String
forall s e. InterpProg s e => s -> RunConfig -> Prog e -> String
gInterpNoLogs s
s RunConfig
runConf Prog b
p2
       String
res2' <- IO String -> (SomeException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force String
res2))
                (\SomeException
exn -> String -> IO String
forall a. HasCallStack => String -> a
error (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Exception while running interpreter on pass result:\n"
                  , String
sepline, String
"\n"
                  , SomeException -> String
forall a. Show a => a -> String
show (SomeException
exn::SomeException), String
"\n"
                  , String
sepline, String
"\n"
                  , String
"Program was: ", Int -> Prog b -> String
forall a. Out a => Int -> a -> String
abbrv Int
300 Prog b
p2
                  ])
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value v -> String
forall a. Show a => a -> String
show Value v
res1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
res2') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"After pass " , String
who
          , String
", evaluating the program yielded the wrong answer.\nReceived:  " , String -> String
forall a. Show a => a -> String
show String
res2'
          , String
"\nExpected:  ", Value v -> String
forall a. Show a => a -> String
show Value v
res1
          ]
       Int -> String -> IO ()
dbgPrintLn Int
interpDbgLevel (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
" [interp] answer after ", String
who
        , String
" was: ", String
res2'
        ]
     Prog b -> StateT (CompileState v) IO (Prog b)
forall a. a -> StateT (CompileState v) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog b
p2