{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}

-- | Utilities and common types.
module Gibbon.Common
       (
         -- * Variables
         Var(..), LocVar, RegVar, fromVar, toVar, varAppend, toEndV, toSeqV, cleanFunName
       , TyVar(..), isUserTv
       , Symbol, intern, unintern

         -- * Gensym monad
       , SyM, gensym, gensym_tag, genLetter, newUniq, runSyM

         -- * PassM monad
       , PassM, runPassM, defaultRunPassM, defaultPackedRunPassM
       , getDynFlags

         -- * Gibbon configuration
       , Config(..), Input(..), Mode(..), Backend(..), defaultConfig
       , RunConfig(..), getRunConfig, defaultRunConfig, getGibbonConfig

         -- * Misc helpers
       , SSModality(..), (#), (!!!), fragileZip, fragileZip', sdoc, ndoc, abbrv
       , lookup3, fst3, snd3, thd3, cataM

         -- * Debugging/logging:
       , dbgLvl, dbgPrint, dbgPrintLn, dbgTrace, dbgTraceIt, minChatLvl
       , internalError, dumpIfSet

         -- * Establish conventions for the output of #lang gibbon:
       , truePrinted, falsePrinted
       )
where

import Control.DeepSeq (NFData(..), force)
import Control.Exception (evaluate)
#if !MIN_VERSION_base(4,13,0)
-- https://downloads.haskell.org/ghc/8.8.1/docs/html/users_guide/8.8.1-notes.html
import Control.Monad.Fail(MonadFail(..))
#endif
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.Functor.Foldable
import Data.Char
import qualified Data.List as L
import Data.Map as M
import Data.String
import qualified Data.Interned as DI
import Data.Interned.String
import Data.Word
import GHC.Generics
import GHC.Stack (HasCallStack)
import Text.PrettyPrint.GenericPretty
import Text.PrettyPrint as PP hiding (Mode(..), Style(..))
import System.IO
import System.Environment
import System.FilePath  ( replaceExtension )
import System.IO.Unsafe ( unsafePerformIO )
import System.Random    ( randomIO )
import Debug.Trace
import Language.C.Quote.CUDA (ToIdent, toIdent)

import Gibbon.DynFlags

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

newtype Symbol = Symbol InternedString
  deriving (Symbol -> Symbol -> Bool
(Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool) -> Eq Symbol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Symbol -> Symbol -> Bool
== :: Symbol -> Symbol -> Bool
$c/= :: Symbol -> Symbol -> Bool
/= :: Symbol -> Symbol -> Bool
Eq, Eq Symbol
Eq Symbol
-> (Symbol -> Symbol -> Ordering)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Symbol)
-> (Symbol -> Symbol -> Symbol)
-> Ord Symbol
Symbol -> Symbol -> Bool
Symbol -> Symbol -> Ordering
Symbol -> Symbol -> Symbol
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Symbol -> Symbol -> Ordering
compare :: Symbol -> Symbol -> Ordering
$c< :: Symbol -> Symbol -> Bool
< :: Symbol -> Symbol -> Bool
$c<= :: Symbol -> Symbol -> Bool
<= :: Symbol -> Symbol -> Bool
$c> :: Symbol -> Symbol -> Bool
> :: Symbol -> Symbol -> Bool
$c>= :: Symbol -> Symbol -> Bool
>= :: Symbol -> Symbol -> Bool
$cmax :: Symbol -> Symbol -> Symbol
max :: Symbol -> Symbol -> Symbol
$cmin :: Symbol -> Symbol -> Symbol
min :: Symbol -> Symbol -> Symbol
Ord)

instance Show Symbol where
    showsPrec :: Int -> Symbol -> ShowS
showsPrec Int
d Symbol
s = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Symbol -> String
unintern Symbol
s)

instance Read Symbol where
    readsPrec :: Int -> ReadS Symbol
readsPrec Int
_d String
t = [(String -> Symbol
intern String
s, String
t') | (String
s, String
t') <- ReadS String
forall a. Read a => ReadS [a]
readList String
t]

instance IsString Symbol where
  fromString :: String -> Symbol
fromString = String -> Symbol
intern

intern :: String -> Symbol
intern :: String -> Symbol
intern = InternedString -> Symbol
Symbol (InternedString -> Symbol)
-> (String -> InternedString) -> String -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InternedString
Uninterned InternedString -> InternedString
forall t. Interned t => Uninterned t -> t
DI.intern

unintern :: Symbol -> String
unintern :: Symbol -> String
unintern (Symbol InternedString
is) = InternedString -> Uninterned InternedString
forall t. Uninternable t => t -> Uninterned t
DI.unintern InternedString
is

-- type CursorVar = Var
newtype Var = Var Symbol
  deriving (Var -> Var -> Bool
(Var -> Var -> Bool) -> (Var -> Var -> Bool) -> Eq Var
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Var -> Var -> Bool
== :: Var -> Var -> Bool
$c/= :: Var -> Var -> Bool
/= :: Var -> Var -> Bool
Eq, Eq Var
Eq Var
-> (Var -> Var -> Ordering)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Var)
-> (Var -> Var -> Var)
-> Ord Var
Var -> Var -> Bool
Var -> Var -> Ordering
Var -> Var -> Var
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Var -> Var -> Ordering
compare :: Var -> Var -> Ordering
$c< :: Var -> Var -> Bool
< :: Var -> Var -> Bool
$c<= :: Var -> Var -> Bool
<= :: Var -> Var -> Bool
$c> :: Var -> Var -> Bool
> :: Var -> Var -> Bool
$c>= :: Var -> Var -> Bool
>= :: Var -> Var -> Bool
$cmax :: Var -> Var -> Var
max :: Var -> Var -> Var
$cmin :: Var -> Var -> Var
min :: Var -> Var -> Var
Ord, ReadPrec [Var]
ReadPrec Var
Int -> ReadS Var
ReadS [Var]
(Int -> ReadS Var)
-> ReadS [Var] -> ReadPrec Var -> ReadPrec [Var] -> Read Var
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Var
readsPrec :: Int -> ReadS Var
$creadList :: ReadS [Var]
readList :: ReadS [Var]
$creadPrec :: ReadPrec Var
readPrec :: ReadPrec Var
$creadListPrec :: ReadPrec [Var]
readListPrec :: ReadPrec [Var]
Read, Int -> Var -> ShowS
[Var] -> ShowS
Var -> String
(Int -> Var -> ShowS)
-> (Var -> String) -> ([Var] -> ShowS) -> Show Var
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Var -> ShowS
showsPrec :: Int -> Var -> ShowS
$cshow :: Var -> String
show :: Var -> String
$cshowList :: [Var] -> ShowS
showList :: [Var] -> ShowS
Show)

instance Out Var where
  doc :: Var -> Doc
doc         = String -> Doc
text (String -> Doc) -> (Var -> String) -> Var -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> String
fromVar
  docPrec :: Int -> Var -> Doc
docPrec Int
n Var
v = Int -> String -> Doc
forall a. Out a => Int -> a -> Doc
docPrec Int
n (Var -> String
fromVar Var
v)

instance NFData Var where
  rnf :: Var -> ()
rnf = String -> ()
forall a. NFData a => a -> ()
rnf (String -> ()) -> (Var -> String) -> Var -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> String
fromVar

instance ToIdent Var where
  toIdent :: Var -> SrcLoc -> Id
toIdent = String -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
toIdent (String -> SrcLoc -> Id) -> (Var -> String) -> Var -> SrcLoc -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> String
fromVar

instance IsString Var where
  fromString :: String -> Var
fromString = String -> Var
toVar

fromVar :: Var -> String
fromVar :: Var -> String
fromVar (Var Symbol
v) = Symbol -> String
unintern Symbol
v

toVar :: String -> Var
toVar :: String -> Var
toVar String
s = Symbol -> Var
Var (Symbol -> Var) -> Symbol -> Var
forall a b. (a -> b) -> a -> b
$ String -> Symbol
intern String
s

-- | String concatenation on variables.
varAppend :: Var -> Var -> Var
varAppend :: Var -> Var -> Var
varAppend Var
x Var
y = String -> Var
toVar (Var -> String
fromVar Var
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> String
fromVar Var
y)

-- | Filter out non-C compatible characters.  This naively assumes it
-- will get no conflicts.  Which may be correct if function names were
-- gensym'd also....
cleanFunName :: Var -> Var
cleanFunName :: Var -> Var
cleanFunName Var
f =
  String -> Var
toVar [ if Char -> Bool
isNumber Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
c
          then Char
c
          else Char
'_'
        | Char
c <- Var -> String
fromVar Var
f ]
toEndV :: Var -> Var
toEndV :: Var -> Var
toEndV = Var -> Var -> Var
varAppend Var
"end_"

toSeqV :: Var -> Var
toSeqV :: Var -> Var
toSeqV Var
v = Var -> Var -> Var
varAppend Var
v (String -> Var
toVar String
"_seq")

-- | Abstract location variables.
type LocVar = Var

-- | Abstract region variables.
type RegVar = Var

-- | Type variables that enable polymorphism.
data TyVar = BoundTv Var         -- Type variable bound by a ForAll.
           | SkolemTv String Int -- Skolem constant, the String is just to improve error messages.
           | UserTv Var          -- Used by the parser. Freshen must replace all occurences.
  deriving (ReadPrec [TyVar]
ReadPrec TyVar
Int -> ReadS TyVar
ReadS [TyVar]
(Int -> ReadS TyVar)
-> ReadS [TyVar]
-> ReadPrec TyVar
-> ReadPrec [TyVar]
-> Read TyVar
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TyVar
readsPrec :: Int -> ReadS TyVar
$creadList :: ReadS [TyVar]
readList :: ReadS [TyVar]
$creadPrec :: ReadPrec TyVar
readPrec :: ReadPrec TyVar
$creadListPrec :: ReadPrec [TyVar]
readListPrec :: ReadPrec [TyVar]
Read, Int -> TyVar -> ShowS
[TyVar] -> ShowS
TyVar -> String
(Int -> TyVar -> ShowS)
-> (TyVar -> String) -> ([TyVar] -> ShowS) -> Show TyVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TyVar -> ShowS
showsPrec :: Int -> TyVar -> ShowS
$cshow :: TyVar -> String
show :: TyVar -> String
$cshowList :: [TyVar] -> ShowS
showList :: [TyVar] -> ShowS
Show, TyVar -> TyVar -> Bool
(TyVar -> TyVar -> Bool) -> (TyVar -> TyVar -> Bool) -> Eq TyVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TyVar -> TyVar -> Bool
== :: TyVar -> TyVar -> Bool
$c/= :: TyVar -> TyVar -> Bool
/= :: TyVar -> TyVar -> Bool
Eq, Eq TyVar
Eq TyVar
-> (TyVar -> TyVar -> Ordering)
-> (TyVar -> TyVar -> Bool)
-> (TyVar -> TyVar -> Bool)
-> (TyVar -> TyVar -> Bool)
-> (TyVar -> TyVar -> Bool)
-> (TyVar -> TyVar -> TyVar)
-> (TyVar -> TyVar -> TyVar)
-> Ord TyVar
TyVar -> TyVar -> Bool
TyVar -> TyVar -> Ordering
TyVar -> TyVar -> TyVar
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TyVar -> TyVar -> Ordering
compare :: TyVar -> TyVar -> Ordering
$c< :: TyVar -> TyVar -> Bool
< :: TyVar -> TyVar -> Bool
$c<= :: TyVar -> TyVar -> Bool
<= :: TyVar -> TyVar -> Bool
$c> :: TyVar -> TyVar -> Bool
> :: TyVar -> TyVar -> Bool
$c>= :: TyVar -> TyVar -> Bool
>= :: TyVar -> TyVar -> Bool
$cmax :: TyVar -> TyVar -> TyVar
max :: TyVar -> TyVar -> TyVar
$cmin :: TyVar -> TyVar -> TyVar
min :: TyVar -> TyVar -> TyVar
Ord, (forall x. TyVar -> Rep TyVar x)
-> (forall x. Rep TyVar x -> TyVar) -> Generic TyVar
forall x. Rep TyVar x -> TyVar
forall x. TyVar -> Rep TyVar x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TyVar -> Rep TyVar x
from :: forall x. TyVar -> Rep TyVar x
$cto :: forall x. Rep TyVar x -> TyVar
to :: forall x. Rep TyVar x -> TyVar
Generic, TyVar -> ()
(TyVar -> ()) -> NFData TyVar
forall a. (a -> ()) -> NFData a
$crnf :: TyVar -> ()
rnf :: TyVar -> ()
NFData)
instance Out TyVar where
  doc :: TyVar -> Doc
doc (BoundTv Var
v)    = String -> Doc
text String
"b:" Doc -> Doc -> Doc
PP.<> Var -> Doc
forall a. Out a => a -> Doc
doc Var
v
  doc (SkolemTv String
s Int
v) = String -> Doc
text String
s Doc -> Doc -> Doc
<+> String -> Doc
text String
"sk:" Doc -> Doc -> Doc
PP.<> Int -> Doc
forall a. Out a => a -> Doc
doc Int
v
  doc (UserTv Var
v)     = String -> Doc
text String
"u:" Doc -> Doc -> Doc
PP.<> Var -> Doc
forall a. Out a => a -> Doc
doc Var
v

  docPrec :: Int -> TyVar -> Doc
docPrec Int
_ = TyVar -> Doc
forall a. Out a => a -> Doc
doc

isUserTv :: TyVar -> Bool
isUserTv :: TyVar -> Bool
isUserTv TyVar
tv =
  case TyVar
tv of
    UserTv{} -> Bool
True
    TyVar
_        -> Bool
False

--------------------------------------------------------------------------------
-- Gensym monad:

newtype SyM a = SyM (State Int a)
  deriving newtype ((forall a b. (a -> b) -> SyM a -> SyM b)
-> (forall a b. a -> SyM b -> SyM a) -> Functor SyM
forall a b. a -> SyM b -> SyM a
forall a b. (a -> b) -> SyM a -> SyM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SyM a -> SyM b
fmap :: forall a b. (a -> b) -> SyM a -> SyM b
$c<$ :: forall a b. a -> SyM b -> SyM a
<$ :: forall a b. a -> SyM b -> SyM a
Functor, Functor SyM
Functor SyM
-> (forall a. a -> SyM a)
-> (forall a b. SyM (a -> b) -> SyM a -> SyM b)
-> (forall a b c. (a -> b -> c) -> SyM a -> SyM b -> SyM c)
-> (forall a b. SyM a -> SyM b -> SyM b)
-> (forall a b. SyM a -> SyM b -> SyM a)
-> Applicative SyM
forall a. a -> SyM a
forall a b. SyM a -> SyM b -> SyM a
forall a b. SyM a -> SyM b -> SyM b
forall a b. SyM (a -> b) -> SyM a -> SyM b
forall a b c. (a -> b -> c) -> SyM a -> SyM b -> SyM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SyM a
pure :: forall a. a -> SyM a
$c<*> :: forall a b. SyM (a -> b) -> SyM a -> SyM b
<*> :: forall a b. SyM (a -> b) -> SyM a -> SyM b
$cliftA2 :: forall a b c. (a -> b -> c) -> SyM a -> SyM b -> SyM c
liftA2 :: forall a b c. (a -> b -> c) -> SyM a -> SyM b -> SyM c
$c*> :: forall a b. SyM a -> SyM b -> SyM b
*> :: forall a b. SyM a -> SyM b -> SyM b
$c<* :: forall a b. SyM a -> SyM b -> SyM a
<* :: forall a b. SyM a -> SyM b -> SyM a
Applicative, Applicative SyM
Applicative SyM
-> (forall a b. SyM a -> (a -> SyM b) -> SyM b)
-> (forall a b. SyM a -> SyM b -> SyM b)
-> (forall a. a -> SyM a)
-> Monad SyM
forall a. a -> SyM a
forall a b. SyM a -> SyM b -> SyM b
forall a b. SyM a -> (a -> SyM b) -> SyM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. SyM a -> (a -> SyM b) -> SyM b
>>= :: forall a b. SyM a -> (a -> SyM b) -> SyM b
$c>> :: forall a b. SyM a -> SyM b -> SyM b
>> :: forall a b. SyM a -> SyM b -> SyM b
$creturn :: forall a. a -> SyM a
return :: forall a. a -> SyM a
Monad, MonadState Int)

instance MonadFail SyM where
  fail :: forall a. String -> SyM a
fail = String -> SyM a
forall a. HasCallStack => String -> a
error

-- | A fresh int.
newUniq :: MonadState Int m => m Int
newUniq :: forall (m :: * -> *). MonadState Int m => m Int
newUniq = (Int -> (Int, Int)) -> m Int
forall a. (Int -> (a, Int)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\Int
x -> (Int
x, Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

-- | Generate a unique symbol by attaching a numeric suffix.
gensym :: MonadState Int m => Var -> m Var
gensym :: forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
v = (Int -> (Var, Int)) -> m Var
forall a. (Int -> (a, Int)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\Int
n -> (Var -> Var
cleanFunName Var
v Var -> Var -> Var
`varAppend` Var
"_" Var -> Var -> Var
`varAppend` String -> Var
toVar (Int -> String
forall a. Show a => a -> String
show Int
n), Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

gensym_tag :: MonadState Int m => Var -> String -> m Var
gensym_tag :: forall (m :: * -> *). MonadState Int m => Var -> String -> m Var
gensym_tag Var
v String
str = (Int -> (Var, Int)) -> m Var
forall a. (Int -> (a, Int)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\Int
n -> (Var -> Var
cleanFunName Var
v Var -> Var -> Var
`varAppend` String -> Var
toVar (Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str) , Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

-- | An infinite alphabet generator: 'a','b', ... ,'z','a0', ...
genLetter :: MonadState Int m => m Var
genLetter :: forall (m :: * -> *). MonadState Int m => m Var
genLetter = do
    let infStream :: String
infStream = ShowS
forall a. HasCallStack => [a] -> [a]
cycle [Char
'a'..Char
'z']
    Int
n <- m Int
forall (m :: * -> *). MonadState Int m => m Int
newUniq
    -- Well, this won't give us exactly what the docs say, but it's good
    -- enough and requires no changes to SyM or PassM.
    Var -> m Var
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> m Var) -> Var -> m Var
forall a b. (a -> b) -> a -> b
$ String -> Var
toVar (String
infStream String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! Int
n Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n)

runSyM :: Int -> SyM a -> (a,Int)
runSyM :: forall a. Int -> SyM a -> (a, Int)
runSyM Int
n (SyM State Int a
a) = State Int a -> Int -> (a, Int)
forall s a. State s a -> s -> (a, s)
runState State Int a
a Int
n

--------------------------------------------------------------------------------
-- Pass monad:

-- | The monad used by core Gibbon passes to access 'Config' and other shared state.
newtype PassM a = PassM (ReaderT Config SyM a)
  deriving newtype ((forall a b. (a -> b) -> PassM a -> PassM b)
-> (forall a b. a -> PassM b -> PassM a) -> Functor PassM
forall a b. a -> PassM b -> PassM a
forall a b. (a -> b) -> PassM a -> PassM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PassM a -> PassM b
fmap :: forall a b. (a -> b) -> PassM a -> PassM b
$c<$ :: forall a b. a -> PassM b -> PassM a
<$ :: forall a b. a -> PassM b -> PassM a
Functor, Functor PassM
Functor PassM
-> (forall a. a -> PassM a)
-> (forall a b. PassM (a -> b) -> PassM a -> PassM b)
-> (forall a b c. (a -> b -> c) -> PassM a -> PassM b -> PassM c)
-> (forall a b. PassM a -> PassM b -> PassM b)
-> (forall a b. PassM a -> PassM b -> PassM a)
-> Applicative PassM
forall a. a -> PassM a
forall a b. PassM a -> PassM b -> PassM a
forall a b. PassM a -> PassM b -> PassM b
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall a b c. (a -> b -> c) -> PassM a -> PassM b -> PassM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> PassM a
pure :: forall a. a -> PassM a
$c<*> :: forall a b. PassM (a -> b) -> PassM a -> PassM b
<*> :: forall a b. PassM (a -> b) -> PassM a -> PassM b
$cliftA2 :: forall a b c. (a -> b -> c) -> PassM a -> PassM b -> PassM c
liftA2 :: forall a b c. (a -> b -> c) -> PassM a -> PassM b -> PassM c
$c*> :: forall a b. PassM a -> PassM b -> PassM b
*> :: forall a b. PassM a -> PassM b -> PassM b
$c<* :: forall a b. PassM a -> PassM b -> PassM a
<* :: forall a b. PassM a -> PassM b -> PassM a
Applicative, Applicative PassM
Applicative PassM
-> (forall a b. PassM a -> (a -> PassM b) -> PassM b)
-> (forall a b. PassM a -> PassM b -> PassM b)
-> (forall a. a -> PassM a)
-> Monad PassM
forall a. a -> PassM a
forall a b. PassM a -> PassM b -> PassM b
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. PassM a -> (a -> PassM b) -> PassM b
>>= :: forall a b. PassM a -> (a -> PassM b) -> PassM b
$c>> :: forall a b. PassM a -> PassM b -> PassM b
>> :: forall a b. PassM a -> PassM b -> PassM b
$creturn :: forall a. a -> PassM a
return :: forall a. a -> PassM a
Monad, MonadReader Config, MonadState Int)

instance MonadFail PassM where
  fail :: forall a. String -> PassM a
fail = String -> PassM a
forall a. HasCallStack => String -> a
error

runPassM :: Config -> Int -> PassM a -> (a,Int)
runPassM :: forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
cfg Int
cnt (PassM ReaderT Config SyM a
pass) = Int -> SyM a -> (a, Int)
forall a. Int -> SyM a -> (a, Int)
runSyM Int
cnt (ReaderT Config SyM a -> Config -> SyM a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Config SyM a
pass Config
cfg)

-- | A convenient wrapper over 'runPassM'.
defaultRunPassM :: PassM a -> (a,Int)
defaultRunPassM :: forall a. PassM a -> (a, Int)
defaultRunPassM = Config -> Int -> PassM a -> (a, Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
defaultConfig Int
0

-- | A convenient wrapper over 'runPassM' for running passes in packed mode.
defaultPackedRunPassM :: PassM a -> (a,Int)
defaultPackedRunPassM :: forall a. PassM a -> (a, Int)
defaultPackedRunPassM = Config -> Int -> PassM a -> (a, Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM (Config
defaultConfig { dynflags :: DynFlags
dynflags = DynFlags
dflags}) Int
0
  where dflags :: DynFlags
dflags = GeneralFlag -> DynFlags -> DynFlags
gopt_set GeneralFlag
Opt_Packed DynFlags
defaultDynFlags

getDynFlags :: MonadReader Config m => m DynFlags
getDynFlags :: forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags = (Config -> DynFlags) -> m DynFlags
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> DynFlags
dynflags

getGibbonConfig :: MonadReader Config m => m Config
getGibbonConfig :: forall (m :: * -> *). MonadReader Config m => m Config
getGibbonConfig = m Config
forall r (m :: * -> *). MonadReader r m => m r
ask

--------------------------------------------------------------------------------
-- Gibbon config:

-- | Overall configuration of the compiler, as determined by command
-- line arguments and possible environment variables.
data Config = Config
  { Config -> Input
input      :: Input
  , Config -> Mode
mode       :: Mode -- ^ How to run, which backend.
  , Config -> Maybe String
benchInput :: Maybe FilePath -- ^ What packed, binary .gpkd file to use as input.
  , Config -> Maybe String
arrayInput :: Maybe FilePath -- ^ What array file to use as input.
  , Config -> Int
verbosity  :: Int   -- ^ Debugging output, equivalent to DEBUG env var.
  , Config -> String
cc         :: String -- ^ C compiler to use
  , Config -> String
optc       :: String -- ^ Options to the C compiler
  , Config -> Maybe String
cfile      :: Maybe FilePath -- ^ Optional override to destination .c file.
  , Config -> Maybe String
exefile    :: Maybe FilePath -- ^ Optional override to destination binary file.
  , Config -> Backend
backend    :: Backend        -- ^ Compilation backend used
  , Config -> DynFlags
dynflags   :: DynFlags
  , Config -> Maybe String
srcFile    :: Maybe FilePath -- ^ The file being compiled by Gibbon.
  }
  deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show, ReadPrec [Config]
ReadPrec Config
Int -> ReadS Config
ReadS [Config]
(Int -> ReadS Config)
-> ReadS [Config]
-> ReadPrec Config
-> ReadPrec [Config]
-> Read Config
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Config
readsPrec :: Int -> ReadS Config
$creadList :: ReadS [Config]
readList :: ReadS [Config]
$creadPrec :: ReadPrec Config
readPrec :: ReadPrec Config
$creadListPrec :: ReadPrec [Config]
readListPrec :: ReadPrec [Config]
Read, Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq, Eq Config
Eq Config
-> (Config -> Config -> Ordering)
-> (Config -> Config -> Bool)
-> (Config -> Config -> Bool)
-> (Config -> Config -> Bool)
-> (Config -> Config -> Bool)
-> (Config -> Config -> Config)
-> (Config -> Config -> Config)
-> Ord Config
Config -> Config -> Bool
Config -> Config -> Ordering
Config -> Config -> Config
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Config -> Config -> Ordering
compare :: Config -> Config -> Ordering
$c< :: Config -> Config -> Bool
< :: Config -> Config -> Bool
$c<= :: Config -> Config -> Bool
<= :: Config -> Config -> Bool
$c> :: Config -> Config -> Bool
> :: Config -> Config -> Bool
$c>= :: Config -> Config -> Bool
>= :: Config -> Config -> Bool
$cmax :: Config -> Config -> Config
max :: Config -> Config -> Config
$cmin :: Config -> Config -> Config
min :: Config -> Config -> Config
Ord)

-- | What input format to expect on disk.
data Input = Haskell
           | SExpr
           | Unspecified
  deriving (Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Input -> ShowS
showsPrec :: Int -> Input -> ShowS
$cshow :: Input -> String
show :: Input -> String
$cshowList :: [Input] -> ShowS
showList :: [Input] -> ShowS
Show,ReadPrec [Input]
ReadPrec Input
Int -> ReadS Input
ReadS [Input]
(Int -> ReadS Input)
-> ReadS [Input]
-> ReadPrec Input
-> ReadPrec [Input]
-> Read Input
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Input
readsPrec :: Int -> ReadS Input
$creadList :: ReadS [Input]
readList :: ReadS [Input]
$creadPrec :: ReadPrec Input
readPrec :: ReadPrec Input
$creadListPrec :: ReadPrec [Input]
readListPrec :: ReadPrec [Input]
Read,Input -> Input -> Bool
(Input -> Input -> Bool) -> (Input -> Input -> Bool) -> Eq Input
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
/= :: Input -> Input -> Bool
Eq,Eq Input
Eq Input
-> (Input -> Input -> Ordering)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Input)
-> (Input -> Input -> Input)
-> Ord Input
Input -> Input -> Bool
Input -> Input -> Ordering
Input -> Input -> Input
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Input -> Input -> Ordering
compare :: Input -> Input -> Ordering
$c< :: Input -> Input -> Bool
< :: Input -> Input -> Bool
$c<= :: Input -> Input -> Bool
<= :: Input -> Input -> Bool
$c> :: Input -> Input -> Bool
> :: Input -> Input -> Bool
$c>= :: Input -> Input -> Bool
>= :: Input -> Input -> Bool
$cmax :: Input -> Input -> Input
max :: Input -> Input -> Input
$cmin :: Input -> Input -> Input
min :: Input -> Input -> Input
Ord,Int -> Input
Input -> Int
Input -> [Input]
Input -> Input
Input -> Input -> [Input]
Input -> Input -> Input -> [Input]
(Input -> Input)
-> (Input -> Input)
-> (Int -> Input)
-> (Input -> Int)
-> (Input -> [Input])
-> (Input -> Input -> [Input])
-> (Input -> Input -> [Input])
-> (Input -> Input -> Input -> [Input])
-> Enum Input
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Input -> Input
succ :: Input -> Input
$cpred :: Input -> Input
pred :: Input -> Input
$ctoEnum :: Int -> Input
toEnum :: Int -> Input
$cfromEnum :: Input -> Int
fromEnum :: Input -> Int
$cenumFrom :: Input -> [Input]
enumFrom :: Input -> [Input]
$cenumFromThen :: Input -> Input -> [Input]
enumFromThen :: Input -> Input -> [Input]
$cenumFromTo :: Input -> Input -> [Input]
enumFromTo :: Input -> Input -> [Input]
$cenumFromThenTo :: Input -> Input -> Input -> [Input]
enumFromThenTo :: Input -> Input -> Input -> [Input]
Enum,Input
Input -> Input -> Bounded Input
forall a. a -> a -> Bounded a
$cminBound :: Input
minBound :: Input
$cmaxBound :: Input
maxBound :: Input
Bounded)

-- | How far to run the compiler/interpreter.
data Mode = ToParse  -- ^ Parse and then stop
          | ToC      -- ^ Compile to C
          | ToExe    -- ^ Compile to C then build a binary.
          | RunExe   -- ^ Compile to executable then run.
          | Interp2  -- ^ Interp late in the compiler pipeline.
          | Interp1  -- ^ Interp early.
          | ToMPL    -- ^ Compile to SML (mlton dialect)
          | ToMPLExe -- ^ Compile to SML & compile with MPL
          | RunMPL   -- ^ Compile to SML & compile with MPL & run
          | Bench Var -- ^ Benchmark a particular function applied to the packed data within an input file.
          | BenchInput FilePath -- ^ Hardcode the input file to the benchmark in the C code.
  deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [Mode] -> ShowS
Show, ReadPrec [Mode]
ReadPrec Mode
Int -> ReadS Mode
ReadS [Mode]
(Int -> ReadS Mode)
-> ReadS [Mode] -> ReadPrec Mode -> ReadPrec [Mode] -> Read Mode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Mode
readsPrec :: Int -> ReadS Mode
$creadList :: ReadS [Mode]
readList :: ReadS [Mode]
$creadPrec :: ReadPrec Mode
readPrec :: ReadPrec Mode
$creadListPrec :: ReadPrec [Mode]
readListPrec :: ReadPrec [Mode]
Read, Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq, Eq Mode
Eq Mode
-> (Mode -> Mode -> Ordering)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Mode)
-> (Mode -> Mode -> Mode)
-> Ord Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Mode -> Mode -> Ordering
compare :: Mode -> Mode -> Ordering
$c< :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
>= :: Mode -> Mode -> Bool
$cmax :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
min :: Mode -> Mode -> Mode
Ord)

-- | Compilation backend used
data Backend = C | LLVM
  deriving (Int -> Backend -> ShowS
[Backend] -> ShowS
Backend -> String
(Int -> Backend -> ShowS)
-> (Backend -> String) -> ([Backend] -> ShowS) -> Show Backend
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Backend -> ShowS
showsPrec :: Int -> Backend -> ShowS
$cshow :: Backend -> String
show :: Backend -> String
$cshowList :: [Backend] -> ShowS
showList :: [Backend] -> ShowS
Show,ReadPrec [Backend]
ReadPrec Backend
Int -> ReadS Backend
ReadS [Backend]
(Int -> ReadS Backend)
-> ReadS [Backend]
-> ReadPrec Backend
-> ReadPrec [Backend]
-> Read Backend
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Backend
readsPrec :: Int -> ReadS Backend
$creadList :: ReadS [Backend]
readList :: ReadS [Backend]
$creadPrec :: ReadPrec Backend
readPrec :: ReadPrec Backend
$creadListPrec :: ReadPrec [Backend]
readListPrec :: ReadPrec [Backend]
Read,Backend -> Backend -> Bool
(Backend -> Backend -> Bool)
-> (Backend -> Backend -> Bool) -> Eq Backend
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Backend -> Backend -> Bool
== :: Backend -> Backend -> Bool
$c/= :: Backend -> Backend -> Bool
/= :: Backend -> Backend -> Bool
Eq,Eq Backend
Eq Backend
-> (Backend -> Backend -> Ordering)
-> (Backend -> Backend -> Bool)
-> (Backend -> Backend -> Bool)
-> (Backend -> Backend -> Bool)
-> (Backend -> Backend -> Bool)
-> (Backend -> Backend -> Backend)
-> (Backend -> Backend -> Backend)
-> Ord Backend
Backend -> Backend -> Bool
Backend -> Backend -> Ordering
Backend -> Backend -> Backend
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Backend -> Backend -> Ordering
compare :: Backend -> Backend -> Ordering
$c< :: Backend -> Backend -> Bool
< :: Backend -> Backend -> Bool
$c<= :: Backend -> Backend -> Bool
<= :: Backend -> Backend -> Bool
$c> :: Backend -> Backend -> Bool
> :: Backend -> Backend -> Bool
$c>= :: Backend -> Backend -> Bool
>= :: Backend -> Backend -> Bool
$cmax :: Backend -> Backend -> Backend
max :: Backend -> Backend -> Backend
$cmin :: Backend -> Backend -> Backend
min :: Backend -> Backend -> Backend
Ord)

defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config { input :: Input
input = Input
Unspecified
         , mode :: Mode
mode  = Mode
ToExe
         , benchInput :: Maybe String
benchInput = Maybe String
forall a. Maybe a
Nothing
         , arrayInput :: Maybe String
arrayInput = Maybe String
forall a. Maybe a
Nothing
         , verbosity :: Int
verbosity = Int
1
         , cc :: String
cc = String
"gcc"
         , optc :: String
optc = String
" -O3  -flto "
         , cfile :: Maybe String
cfile = Maybe String
forall a. Maybe a
Nothing
         , exefile :: Maybe String
exefile = Maybe String
forall a. Maybe a
Nothing
         , backend :: Backend
backend = Backend
C
         , dynflags :: DynFlags
dynflags = DynFlags
defaultDynFlags
         , srcFile :: Maybe String
srcFile = Maybe String
forall a. Maybe a
Nothing
         }

-- | Runtime configuration for executing interpreters.
data RunConfig =
    RunConfig { RunConfig -> Int
rcSize  :: Int
              , RunConfig -> Word64
rcIters :: Word64
              , RunConfig -> Int
rcDbg   :: Int
              , RunConfig -> Bool
rcCursors :: Bool -- ^ Do we support cursors in L1.Exp at this point in the compiler.
              }

defaultRunConfig :: RunConfig
defaultRunConfig :: RunConfig
defaultRunConfig = RunConfig { rcSize :: Int
rcSize  = Int
1
                             , rcIters :: Word64
rcIters = Word64
1
                             , rcDbg :: Int
rcDbg   = Int
1
                             , rcCursors :: Bool
rcCursors = Bool
False
                             }

-- | We currently use the hacky approach of using env vars OR command
-- line args to set the two universal benchmark params: SIZE and ITERS.
--
-- This takes extra, optional command line args [Size, Iters] provided
-- after the file to process on the command line.  If these are not
-- present it
getRunConfig :: [String] -> IO RunConfig
getRunConfig :: [String] -> IO RunConfig
getRunConfig [String]
ls =
 case [String]
ls of
   [] -> case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
"GIBBON_SIZE" [(String, String)]
theEnv of
           Maybe String
Nothing -> [String] -> IO RunConfig
getRunConfig [String
"1"]
           Just String
n  -> [String] -> IO RunConfig
getRunConfig [String
n]
   [String
sz] -> case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
"GIBBON_ITERS" [(String, String)]
theEnv  of
             Maybe String
Nothing -> [String] -> IO RunConfig
getRunConfig [String
sz,String
"1"]
             Just String
i  -> [String] -> IO RunConfig
getRunConfig [String
sz,String
i]
   [String
sz,String
iters] ->
     RunConfig -> IO RunConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RunConfig -> IO RunConfig) -> RunConfig -> IO RunConfig
forall a b. (a -> b) -> a -> b
$ RunConfig { rcSize :: Int
rcSize=String -> Int
forall a. Read a => String -> a
read String
sz, rcIters :: Word64
rcIters=String -> Word64
forall a. Read a => String -> a
read String
iters, rcDbg :: Int
rcDbg= Int
dbgLvl, rcCursors :: Bool
rcCursors= Bool
False }
   [String]
_ -> String -> IO RunConfig
forall a. HasCallStack => String -> a
error (String -> IO RunConfig) -> String -> IO RunConfig
forall a b. (a -> b) -> a -> b
$ String
"getRunConfig: too many command line args, expected <size> <iters> at most: "String -> ShowS
forall a. [a] -> [a] -> [a]
++[String] -> String
forall a. Show a => a -> String
show [String]
ls

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

data SSModality = Read | Write
  deriving (ReadPrec [SSModality]
ReadPrec SSModality
Int -> ReadS SSModality
ReadS [SSModality]
(Int -> ReadS SSModality)
-> ReadS [SSModality]
-> ReadPrec SSModality
-> ReadPrec [SSModality]
-> Read SSModality
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SSModality
readsPrec :: Int -> ReadS SSModality
$creadList :: ReadS [SSModality]
readList :: ReadS [SSModality]
$creadPrec :: ReadPrec SSModality
readPrec :: ReadPrec SSModality
$creadListPrec :: ReadPrec [SSModality]
readListPrec :: ReadPrec [SSModality]
Read, Int -> SSModality -> ShowS
[SSModality] -> ShowS
SSModality -> String
(Int -> SSModality -> ShowS)
-> (SSModality -> String)
-> ([SSModality] -> ShowS)
-> Show SSModality
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SSModality -> ShowS
showsPrec :: Int -> SSModality -> ShowS
$cshow :: SSModality -> String
show :: SSModality -> String
$cshowList :: [SSModality] -> ShowS
showList :: [SSModality] -> ShowS
Show, SSModality -> SSModality -> Bool
(SSModality -> SSModality -> Bool)
-> (SSModality -> SSModality -> Bool) -> Eq SSModality
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SSModality -> SSModality -> Bool
== :: SSModality -> SSModality -> Bool
$c/= :: SSModality -> SSModality -> Bool
/= :: SSModality -> SSModality -> Bool
Eq, Eq SSModality
Eq SSModality
-> (SSModality -> SSModality -> Ordering)
-> (SSModality -> SSModality -> Bool)
-> (SSModality -> SSModality -> Bool)
-> (SSModality -> SSModality -> Bool)
-> (SSModality -> SSModality -> Bool)
-> (SSModality -> SSModality -> SSModality)
-> (SSModality -> SSModality -> SSModality)
-> Ord SSModality
SSModality -> SSModality -> Bool
SSModality -> SSModality -> Ordering
SSModality -> SSModality -> SSModality
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SSModality -> SSModality -> Ordering
compare :: SSModality -> SSModality -> Ordering
$c< :: SSModality -> SSModality -> Bool
< :: SSModality -> SSModality -> Bool
$c<= :: SSModality -> SSModality -> Bool
<= :: SSModality -> SSModality -> Bool
$c> :: SSModality -> SSModality -> Bool
> :: SSModality -> SSModality -> Bool
$c>= :: SSModality -> SSModality -> Bool
>= :: SSModality -> SSModality -> Bool
$cmax :: SSModality -> SSModality -> SSModality
max :: SSModality -> SSModality -> SSModality
$cmin :: SSModality -> SSModality -> SSModality
min :: SSModality -> SSModality -> SSModality
Ord, (forall x. SSModality -> Rep SSModality x)
-> (forall x. Rep SSModality x -> SSModality) -> Generic SSModality
forall x. Rep SSModality x -> SSModality
forall x. SSModality -> Rep SSModality x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SSModality -> Rep SSModality x
from :: forall x. SSModality -> Rep SSModality x
$cto :: forall x. Rep SSModality x -> SSModality
to :: forall x. Rep SSModality x -> SSModality
Generic, SSModality -> ()
(SSModality -> ()) -> NFData SSModality
forall a. (a -> ()) -> NFData a
$crnf :: SSModality -> ()
rnf :: SSModality -> ()
NFData, Int -> SSModality -> Doc
[SSModality] -> Doc
SSModality -> Doc
(Int -> SSModality -> Doc)
-> (SSModality -> Doc) -> ([SSModality] -> Doc) -> Out SSModality
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> SSModality -> Doc
docPrec :: Int -> SSModality -> Doc
$cdoc :: SSModality -> Doc
doc :: SSModality -> Doc
$cdocList :: [SSModality] -> Doc
docList :: [SSModality] -> Doc
Out)

-- | An alias for the error function we want to use throughout this project.
{-# INLINE err #-}
err :: HasCallStack => String -> a
err :: forall a. HasCallStack => String -> a
err = String -> a
forall a. HasCallStack => String -> a
error

-- | An error that is OUR FAULT, i.e. an internal bug in the compiler.
internalError :: HasCallStack => String -> a
internalError :: forall a. HasCallStack => String -> a
internalError String
s = String -> a
forall a. HasCallStack => String -> a
error (String
"internal error: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
s)

instance (Out k,Out v) => Out (Map k v) where
  doc :: Map k v -> Doc
doc         = [(k, v)] -> Doc
forall a. Out a => a -> Doc
doc ([(k, v)] -> Doc) -> (Map k v -> [(k, v)]) -> Map k v -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
M.toList
  docPrec :: Int -> Map k v -> Doc
docPrec Int
n Map k v
v = Int -> [(k, v)] -> Doc
forall a. Out a => Int -> a -> Doc
docPrec Int
n (Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
M.toList Map k v
v)

(#) :: (Ord a, Out a, Out b, Show a, HasCallStack) => Map a b -> a -> b
Map a b
m # :: forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# a
k = case a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
k Map a b
m of
          Just b
x  -> b
x
          Maybe b
Nothing -> String -> b
forall a. HasCallStack => String -> a
err (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"Map lookup failed on key: "String -> ShowS
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
k
                     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in map:\n "String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map a b -> String
forall a. Out a => a -> String
sdoc Map a b
m


(!!!) :: (Out a, HasCallStack) => [a] -> Int -> a
[a]
ls0 !!! :: forall a. (Out a, HasCallStack) => [a] -> Int -> a
!!! Int
ix0 = [a] -> Int -> a
go [a]
ls0 Int
ix0
 where
   go :: [a] -> Int -> a
go [] Int
_ = String -> a
forall a. HasCallStack => String -> a
err (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Not enough elements in list to retrieve "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
ix0
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++String
", list:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> String
forall a. Out a => Int -> a -> String
abbrv Int
300 [a]
ls0
   go (a
x:[a]
_) Int
0 = a
x
   go (a
_:[a]
xs) Int
n = [a] -> Int -> a
go [a]
xs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)


fragileZip :: (Show a, Show b, HasCallStack) => [a] -> [b] -> [(a, b)]
fragileZip :: forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [] [] = []
fragileZip (a
a:[a]
as) (b
b:[b]
bs) = (a
a,b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [(a, b)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [a]
as [b]
bs
fragileZip [a]
as [] = String -> [(a, b)]
forall a. HasCallStack => String -> a
err(String -> [(a, b)]) -> String -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ String
"fragileZip: right ran out, while left still has: "String -> ShowS
forall a. [a] -> [a] -> [a]
++[a] -> String
forall a. Show a => a -> String
show [a]
as
fragileZip [] [b]
bs = String -> [(a, b)]
forall a. HasCallStack => String -> a
err(String -> [(a, b)]) -> String -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ String
"fragileZip: left ran out, while right still has: "String -> ShowS
forall a. [a] -> [a] -> [a]
++[b] -> String
forall a. Show a => a -> String
show [b]
bs


-- | Like fragileZip, but takes a custom error message.
fragileZip' :: (Show a, Show b, HasCallStack) => [a] -> [b] -> String -> [(a, b)]
fragileZip' :: forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> String -> [(a, b)]
fragileZip' [] [] String
_ = []
fragileZip' (a
a:[a]
as) (b
b:[b]
bs) String
m = (a
a,b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> String -> [(a, b)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> String -> [(a, b)]
fragileZip' [a]
as [b]
bs String
m
fragileZip' [a]
_ [] String
m = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
m
fragileZip' [] [b]
_ String
m = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
m

-- | Handy combination of show and doc
sdoc :: Out a => a -> String
sdoc :: forall a. Out a => a -> String
sdoc = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Out a => a -> Doc
doc

-- | Like sdoc but inserts newline if it is longish.
ndoc :: Out a => a -> String
ndoc :: forall a. Out a => a -> String
ndoc a
x = let s :: String
s = a -> String
forall a. Out a => a -> String
sdoc a
x in
         if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
40
         then String
"\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
         else String
s

-- | Like ndoc/sdoc but cut it off with "..." after a char limit.
abbrv :: (Out a) => Int -> a -> String
abbrv :: forall a. Out a => Int -> a -> String
abbrv Int
n a
x =
    let str :: String
str = Doc -> String
forall a. Show a => a -> String
show (a -> Doc
forall a. Out a => a -> Doc
doc a
x)
        len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
    in if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n
       then String
str
       else Int -> ShowS
forall a. Int -> [a] -> [a]
L.take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
3) String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."

lookup3 :: (Eq k, Show k, Show a, Show b) => k -> [(k,a,b)] -> (k,a,b)
lookup3 :: forall k a b.
(Eq k, Show k, Show a, Show b) =>
k -> [(k, a, b)] -> (k, a, b)
lookup3 k
k [(k, a, b)]
ls = [(k, a, b)] -> (k, a, b)
go [(k, a, b)]
ls
  where
   go :: [(k, a, b)] -> (k, a, b)
go [] = String -> (k, a, b)
forall a. HasCallStack => String -> a
error(String -> (k, a, b)) -> String -> (k, a, b)
forall a b. (a -> b) -> a -> b
$ String
"lookup3: key "String -> ShowS
forall a. [a] -> [a] -> [a]
++k -> String
forall a. Show a => a -> String
show k
kString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" not found in list:\n  "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
L.take Int
80 ([(k, a, b)] -> String
forall a. Show a => a -> String
show [(k, a, b)]
ls)
   go ((k
k1,a
a1,b
b1):[(k, a, b)]
r)
      | k
k1 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k   = (k
k1,a
a1,b
b1)
      | Bool
otherwise = [(k, a, b)] -> (k, a, b)
go [(k, a, b)]
r

fst3 :: (a,b,c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a,b
_,c
_) = a
a

snd3 :: (a,b,c) -> b
snd3 :: forall a b c. (a, b, c) -> b
snd3 (a
_,b
b,c
_) = b
b

thd3 :: (a,b,c) -> c
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_,b
_,c
c) = c
c

cataM
  :: (Monad m, Traversable (Base t), Recursive t)
  => (Base t a -> m a) -> t ->  m a
cataM :: forall (m :: * -> *) t a.
(Monad m, Traversable (Base t), Recursive t) =>
(Base t a -> m a) -> t -> m a
cataM Base t a -> m a
alg = t -> m a
c where
    c :: t -> m a
c = Base t a -> m a
alg (Base t a -> m a) -> (t -> m (Base t a)) -> t -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (t -> m a) -> Base t t -> m (Base t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Base t a -> f (Base t b)
traverse t -> m a
c (Base t t -> m (Base t a)) -> (t -> Base t t) -> t -> m (Base t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project


--------------------------------------------------------------------------------
-- DEBUGGING
--------------------------------------------------------------------------------

theEnv :: [(String, String)]
{-# NOINLINE theEnv #-}
theEnv :: [(String, String)]
theEnv = IO [(String, String)] -> [(String, String)]
forall a. IO a -> a
unsafePerformIO IO [(String, String)]
getEnvironment

-- | Debugging flag shared by all modules.
--   This is activated by setting the environment variable DEBUG=1..5
dbgLvl :: Int
dbgLvl :: Int
dbgLvl = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
"GIBBON_DEBUG" [(String, String)]
theEnv of
       Maybe String
Nothing  -> Int
defaultDbg
       Just String
""  -> Int
defaultDbg
       Just String
"0" -> Int
defaultDbg
       Just String
s   ->
         case ReadS Int
forall a. Read a => ReadS a
reads String
s of
           ((Int
n,String
_):[(Int, String)]
_) ->
               if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minChatLvl
               then String -> Int -> Int
forall a. String -> a -> a
trace (String
" ! Responding to env Var: GIBBON_DEBUG="String -> ShowS
forall a. [a] -> [a] -> [a]
++String
s) Int
n
               else Int
n
           [] -> String -> Int
forall a. HasCallStack => String -> a
error(String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$String
"Attempt to parse GIBBON_DEBUG env var as Int failed: "String -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
forall a. Show a => a -> String
show String
s

-- | We should not create chatter below this level.  DEBUG=1 is used
-- for assertions only, not chatter.
minChatLvl :: Int
minChatLvl :: Int
minChatLvl = Int
2

defaultDbg :: Int
defaultDbg :: Int
defaultDbg = Int
0

-- | Print if the debug level is at or above a threshold.
dbgPrint :: Int -> String -> IO ()
dbgPrint :: Int -> String -> IO ()
dbgPrint Int
lvl String
str = if Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lvl then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else do
    String
_ <- String -> IO String
forall a. a -> IO a
evaluate (ShowS
forall a. NFData a => a -> a
force String
str) -- Force it first to squeeze out any dbgTrace msgs.
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
str

dbgPrintLn :: Int -> String -> IO ()
dbgPrintLn :: Int -> String -> IO ()
dbgPrintLn Int
lvl String
str = Int -> String -> IO ()
dbgPrint Int
lvl (String
strString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\n")

-- | Conditional version of Debug.Trace.trace
dbgTrace :: Int -> String -> a -> a
dbgTrace :: forall a. Int -> String -> a -> a
dbgTrace Int
lvl String
msg a
val =
    if   Int
dbgLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lvl
    then a
val
    else String -> a -> a
forall a. String -> a -> a
trace String
msg a
val

-- | Yo, trace this msg.
dbgTraceIt :: String -> a -> a
dbgTraceIt :: forall a. String -> a -> a
dbgTraceIt = String -> a -> a
forall a. String -> a -> a
trace

-- | Dump some output if the flag is set. Otherwise, do nothing.
dumpIfSet :: Config -> DebugFlag -> String -> IO ()
dumpIfSet :: Config -> DebugFlag -> String -> IO ()
dumpIfSet Config
cfg DebugFlag
flag String
msg =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DebugFlag -> DynFlags -> Bool
dopt DebugFlag
flag DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    if Bool -> Bool
not Bool
dump_to_file
    then String -> IO ()
putStrLn String
msg
    else do
      String
fp <- case Maybe String
src_file of
              Just String
fp -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> ShowS
replaceExtension String
fp String
suffix
              Maybe String
Nothing -> do
                Int
n <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int
                let fp :: String
fp = String
"gibbon-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix
                String -> IO String -> IO String
forall a. String -> a -> a
dbgTraceIt (String
"dumpIfSet: Got -ddump-to-file, but 'srcFile' is not set in config. Dumping output to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp) (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
fp)
      String -> String -> IO ()
writeFile String
fp (String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  where
    src_file :: Maybe String
src_file     = Config -> Maybe String
srcFile Config
cfg
    dflags :: DynFlags
dflags       = Config -> DynFlags
dynflags Config
cfg
    dump_to_file :: Bool
dump_to_file = DebugFlag -> DynFlags -> Bool
dopt DebugFlag
Opt_D_DumpToFile DynFlags
dflags
    suffix :: String
suffix       = DebugFlag -> String
debugFlagSuffix DebugFlag
flag

-- A nice filename suffix for each flag.
debugFlagSuffix :: DebugFlag -> String
debugFlagSuffix :: DebugFlag -> String
debugFlagSuffix DebugFlag
f =
  case DebugFlag
f of
    DebugFlag
Opt_D_Dump_Repair   -> String
"dump-repair"
    DebugFlag
Opt_D_Dump_ParAlloc -> String
"dump-paralloc"
    DebugFlag
Opt_D_DumpToFile    -> String
"dump-to-file" -- This would never be used.
    DebugFlag
Opt_D_Dump_Hs       -> String
"gibbon_hs.hs"

--------------------------------------------------------------------------------
-- Some global constants

-- | For now this is designed to match the Racket output of "#lang
-- gibbon" which itself should change once we implement a custom
-- printer.
truePrinted :: String
truePrinted :: String
truePrinted = String
"#t"

falsePrinted :: String
falsePrinted :: String
falsePrinted = String
"#f"