{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | The source language for recursive tree traversals.
--   This is a first-order language for the "closed world" scenario:
--   not integrating with a functional host language, but rather
--   genarating C code like a DSL.

module Gibbon.L1.Syntax
    (
      -- * Core types specific to L1
      Prog1, FunDef1, FunDefs1, DDef1, DDefs1, Exp1, Ty1, E1Ext(..)
    , module Gibbon.Language
    ) where

import Control.DeepSeq ( NFData )
import qualified Data.Set as S
import GHC.Generics
import Text.PrettyPrint.GenericPretty

import Gibbon.Language
import Gibbon.Common

import qualified Data.Map                       as M
import           Prelude                        as P

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

instance FunctionTy Ty1 where
  -- | At this stage, function types are just (in , out) tuples.
  type ArrowTy Ty1 = ([Ty1] , Ty1)
  inTys :: ArrowTy Ty1 -> [Ty1]
inTys = ([Ty1], Ty1) -> [Ty1]
ArrowTy Ty1 -> [Ty1]
forall a b. (a, b) -> a
fst
  outTy :: ArrowTy Ty1 -> Ty1
outTy = ([Ty1], Ty1) -> Ty1
ArrowTy Ty1 -> Ty1
forall a b. (a, b) -> b
snd

-- | A convenient, default instantiation of the L1 expression type.
type Exp1 = PreExp E1Ext () Ty1

-- | An L1 program.
type Prog1 = Prog Exp1

-- | Datatypes
type DDefs1 = DDefs Ty1
type DDef1  = DDef Ty1

-- | Function definition used in L1 programs.
type FunDef1 = FunDef Exp1

type FunDefs1 = FunDefs Exp1

-- | The type rperesentation used in L1.
type Ty1 = UrTy ()


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

data E1Ext loc dec = BenchE Var [loc] [(PreExp E1Ext loc dec)] Bool
                   | AddFixed Var Int     -- Created by AddRAN.
                   | StartOfPkdCursor Var -- Created by AddRAN.
  deriving (Int -> E1Ext loc dec -> ShowS
[E1Ext loc dec] -> ShowS
E1Ext loc dec -> String
(Int -> E1Ext loc dec -> ShowS)
-> (E1Ext loc dec -> String)
-> ([E1Ext loc dec] -> ShowS)
-> Show (E1Ext loc dec)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall loc dec.
(Show loc, Show dec) =>
Int -> E1Ext loc dec -> ShowS
forall loc dec. (Show loc, Show dec) => [E1Ext loc dec] -> ShowS
forall loc dec. (Show loc, Show dec) => E1Ext loc dec -> String
$cshowsPrec :: forall loc dec.
(Show loc, Show dec) =>
Int -> E1Ext loc dec -> ShowS
showsPrec :: Int -> E1Ext loc dec -> ShowS
$cshow :: forall loc dec. (Show loc, Show dec) => E1Ext loc dec -> String
show :: E1Ext loc dec -> String
$cshowList :: forall loc dec. (Show loc, Show dec) => [E1Ext loc dec] -> ShowS
showList :: [E1Ext loc dec] -> ShowS
Show, Eq (E1Ext loc dec)
Eq (E1Ext loc dec)
-> (E1Ext loc dec -> E1Ext loc dec -> Ordering)
-> (E1Ext loc dec -> E1Ext loc dec -> Bool)
-> (E1Ext loc dec -> E1Ext loc dec -> Bool)
-> (E1Ext loc dec -> E1Ext loc dec -> Bool)
-> (E1Ext loc dec -> E1Ext loc dec -> Bool)
-> (E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec)
-> (E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec)
-> Ord (E1Ext loc dec)
E1Ext loc dec -> E1Ext loc dec -> Bool
E1Ext loc dec -> E1Ext loc dec -> Ordering
E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
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
forall {loc} {dec}. (Ord loc, Ord dec) => Eq (E1Ext loc dec)
forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Ordering
forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
$ccompare :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Ordering
compare :: E1Ext loc dec -> E1Ext loc dec -> Ordering
$c< :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
< :: E1Ext loc dec -> E1Ext loc dec -> Bool
$c<= :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
<= :: E1Ext loc dec -> E1Ext loc dec -> Bool
$c> :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
> :: E1Ext loc dec -> E1Ext loc dec -> Bool
$c>= :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
>= :: E1Ext loc dec -> E1Ext loc dec -> Bool
$cmax :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
max :: E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
$cmin :: forall loc dec.
(Ord loc, Ord dec) =>
E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
min :: E1Ext loc dec -> E1Ext loc dec -> E1Ext loc dec
Ord, E1Ext loc dec -> E1Ext loc dec -> Bool
(E1Ext loc dec -> E1Ext loc dec -> Bool)
-> (E1Ext loc dec -> E1Ext loc dec -> Bool) -> Eq (E1Ext loc dec)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall loc dec.
(Eq loc, Eq dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
$c== :: forall loc dec.
(Eq loc, Eq dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
== :: E1Ext loc dec -> E1Ext loc dec -> Bool
$c/= :: forall loc dec.
(Eq loc, Eq dec) =>
E1Ext loc dec -> E1Ext loc dec -> Bool
/= :: E1Ext loc dec -> E1Ext loc dec -> Bool
Eq, ReadPrec [E1Ext loc dec]
ReadPrec (E1Ext loc dec)
Int -> ReadS (E1Ext loc dec)
ReadS [E1Ext loc dec]
(Int -> ReadS (E1Ext loc dec))
-> ReadS [E1Ext loc dec]
-> ReadPrec (E1Ext loc dec)
-> ReadPrec [E1Ext loc dec]
-> Read (E1Ext loc dec)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall loc dec. (Read loc, Read dec) => ReadPrec [E1Ext loc dec]
forall loc dec. (Read loc, Read dec) => ReadPrec (E1Ext loc dec)
forall loc dec.
(Read loc, Read dec) =>
Int -> ReadS (E1Ext loc dec)
forall loc dec. (Read loc, Read dec) => ReadS [E1Ext loc dec]
$creadsPrec :: forall loc dec.
(Read loc, Read dec) =>
Int -> ReadS (E1Ext loc dec)
readsPrec :: Int -> ReadS (E1Ext loc dec)
$creadList :: forall loc dec. (Read loc, Read dec) => ReadS [E1Ext loc dec]
readList :: ReadS [E1Ext loc dec]
$creadPrec :: forall loc dec. (Read loc, Read dec) => ReadPrec (E1Ext loc dec)
readPrec :: ReadPrec (E1Ext loc dec)
$creadListPrec :: forall loc dec. (Read loc, Read dec) => ReadPrec [E1Ext loc dec]
readListPrec :: ReadPrec [E1Ext loc dec]
Read, (forall x. E1Ext loc dec -> Rep (E1Ext loc dec) x)
-> (forall x. Rep (E1Ext loc dec) x -> E1Ext loc dec)
-> Generic (E1Ext loc dec)
forall x. Rep (E1Ext loc dec) x -> E1Ext loc dec
forall x. E1Ext loc dec -> Rep (E1Ext loc dec) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall loc dec x. Rep (E1Ext loc dec) x -> E1Ext loc dec
forall loc dec x. E1Ext loc dec -> Rep (E1Ext loc dec) x
$cfrom :: forall loc dec x. E1Ext loc dec -> Rep (E1Ext loc dec) x
from :: forall x. E1Ext loc dec -> Rep (E1Ext loc dec) x
$cto :: forall loc dec x. Rep (E1Ext loc dec) x -> E1Ext loc dec
to :: forall x. Rep (E1Ext loc dec) x -> E1Ext loc dec
Generic, E1Ext loc dec -> ()
(E1Ext loc dec -> ()) -> NFData (E1Ext loc dec)
forall a. (a -> ()) -> NFData a
forall loc dec. (NFData loc, NFData dec) => E1Ext loc dec -> ()
$crnf :: forall loc dec. (NFData loc, NFData dec) => E1Ext loc dec -> ()
rnf :: E1Ext loc dec -> ()
NFData, Int -> E1Ext loc dec -> Doc
[E1Ext loc dec] -> Doc
E1Ext loc dec -> Doc
(Int -> E1Ext loc dec -> Doc)
-> (E1Ext loc dec -> Doc)
-> ([E1Ext loc dec] -> Doc)
-> Out (E1Ext loc dec)
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
forall loc dec. (Out loc, Out dec) => Int -> E1Ext loc dec -> Doc
forall loc dec. (Out loc, Out dec) => [E1Ext loc dec] -> Doc
forall loc dec. (Out loc, Out dec) => E1Ext loc dec -> Doc
$cdocPrec :: forall loc dec. (Out loc, Out dec) => Int -> E1Ext loc dec -> Doc
docPrec :: Int -> E1Ext loc dec -> Doc
$cdoc :: forall loc dec. (Out loc, Out dec) => E1Ext loc dec -> Doc
doc :: E1Ext loc dec -> Doc
$cdocList :: forall loc dec. (Out loc, Out dec) => [E1Ext loc dec] -> Doc
docList :: [E1Ext loc dec] -> Doc
Out)

instance FreeVars (E1Ext l d) where
  gFreeVars :: E1Ext l d -> Set Var
gFreeVars E1Ext l d
e =
    case E1Ext l d
e of
      BenchE Var
_ [l]
_ [PreExp E1Ext l d]
args Bool
_-> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((PreExp E1Ext l d -> Set Var) -> [PreExp E1Ext l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
map PreExp E1Ext l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp E1Ext l d]
args)
      AddFixed Var
v Int
_ -> Var -> Set Var
forall a. a -> Set a
S.singleton Var
v
      StartOfPkdCursor Var
cur -> Var -> Set Var
forall a. a -> Set a
S.singleton Var
cur

instance (Show l, Show d, Out l, Out d) => Expression (E1Ext l d) where
  type TyOf  (E1Ext l d) = d
  type LocOf (E1Ext l d) = l
  isTrivial :: E1Ext l d -> Bool
isTrivial E1Ext l d
_ = Bool
False

instance (Show l, Show d, Out l, Out d) => Flattenable (E1Ext l d) where
  gFlattenGatherBinds :: DDefs (TyOf (E1Ext l d))
-> Env2 (TyOf (E1Ext l d))
-> E1Ext l d
-> PassM ([Binds (E1Ext l d)], E1Ext l d)
gFlattenGatherBinds DDefs (TyOf (E1Ext l d))
_ddfs Env2 (TyOf (E1Ext l d))
_env E1Ext l d
ex = ([(Var, [l], d, E1Ext l d)], E1Ext l d)
-> PassM ([(Var, [l], d, E1Ext l d)], E1Ext l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], E1Ext l d
ex)
  gFlattenExp :: DDefs (TyOf (E1Ext l d))
-> Env2 (TyOf (E1Ext l d)) -> E1Ext l d -> PassM (E1Ext l d)
gFlattenExp DDefs (TyOf (E1Ext l d))
_ddfs Env2 (TyOf (E1Ext l d))
_env E1Ext l d
ex = E1Ext l d -> PassM (E1Ext l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return E1Ext l d
ex

instance HasSimplifiableExt E1Ext l d => SimplifiableExt (PreExp E1Ext l d) (E1Ext l d) where
  gInlineTrivExt :: Map Var (PreExp E1Ext l d) -> E1Ext l d -> E1Ext l d
gInlineTrivExt Map Var (PreExp E1Ext l d)
_env E1Ext l d
ext = E1Ext l d
ext

instance HasSubstitutableExt E1Ext l d => SubstitutableExt (PreExp E1Ext l d) (E1Ext l d) where
  gSubstExt :: Var -> PreExp E1Ext l d -> E1Ext l d -> E1Ext l d
gSubstExt Var
old PreExp E1Ext l d
new E1Ext l d
ext =
    case E1Ext l d
ext of
      BenchE Var
fn [l]
tyapps [PreExp E1Ext l d]
args Bool
b -> Var -> [l] -> [PreExp E1Ext l d] -> Bool -> E1Ext l d
forall loc dec.
Var -> [loc] -> [PreExp E1Ext loc dec] -> Bool -> E1Ext loc dec
BenchE Var
fn [l]
tyapps ((PreExp E1Ext l d -> PreExp E1Ext l d)
-> [PreExp E1Ext l d] -> [PreExp E1Ext l d]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> PreExp E1Ext l d -> PreExp E1Ext l d -> PreExp E1Ext l d
forall e. Substitutable e => Var -> e -> e -> e
gSubst Var
old PreExp E1Ext l d
new) [PreExp E1Ext l d]
args) Bool
b
      AddFixed Var
v Int
i -> if Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old
                      then case PreExp E1Ext l d
new of
                             (VarE Var
v') -> Var -> Int -> E1Ext l d
forall loc dec. Var -> Int -> E1Ext loc dec
AddFixed Var
v' Int
i
                             PreExp E1Ext l d
_oth -> String -> E1Ext l d
forall a. HasCallStack => String -> a
error String
"Could not substitute non-variable in AddFixed"
                      else Var -> Int -> E1Ext l d
forall loc dec. Var -> Int -> E1Ext loc dec
AddFixed Var
v Int
i
      StartOfPkdCursor Var
cur ->
                     if Var
cur Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old
                     then case PreExp E1Ext l d
new of
                             VarE Var
cur' -> Var -> E1Ext l d
forall loc dec. Var -> E1Ext loc dec
StartOfPkdCursor Var
cur'
                             PreExp E1Ext l d
_oth -> String -> E1Ext l d
forall a. HasCallStack => String -> a
error String
"Could not substitute non-variable in StartOfPkdCursor"
                     else (Var -> E1Ext l d
forall loc dec. Var -> E1Ext loc dec
StartOfPkdCursor Var
cur)

  gSubstEExt :: PreExp E1Ext l d -> PreExp E1Ext l d -> E1Ext l d -> E1Ext l d
gSubstEExt PreExp E1Ext l d
old PreExp E1Ext l d
new E1Ext l d
ext =
    case E1Ext l d
ext of
      BenchE Var
fn [l]
tyapps [PreExp E1Ext l d]
args Bool
b -> Var -> [l] -> [PreExp E1Ext l d] -> Bool -> E1Ext l d
forall loc dec.
Var -> [loc] -> [PreExp E1Ext loc dec] -> Bool -> E1Ext loc dec
BenchE Var
fn [l]
tyapps ((PreExp E1Ext l d -> PreExp E1Ext l d)
-> [PreExp E1Ext l d] -> [PreExp E1Ext l d]
forall a b. (a -> b) -> [a] -> [b]
map (PreExp E1Ext l d
-> PreExp E1Ext l d -> PreExp E1Ext l d -> PreExp E1Ext l d
forall e. Substitutable e => e -> e -> e -> e
gSubstE PreExp E1Ext l d
old PreExp E1Ext l d
new) [PreExp E1Ext l d]
args) Bool
b
      AddFixed Var
v Int
i -> Var -> Int -> E1Ext l d
forall loc dec. Var -> Int -> E1Ext loc dec
AddFixed Var
v Int
i
      StartOfPkdCursor Var
cur  -> Var -> E1Ext l d
forall loc dec. Var -> E1Ext loc dec
StartOfPkdCursor Var
cur

instance Typeable (E1Ext () (UrTy ())) where
  gRecoverType :: DDefs (TyOf (E1Ext () Ty1))
-> Env2 (TyOf (E1Ext () Ty1))
-> E1Ext () Ty1
-> TyOf (E1Ext () Ty1)
gRecoverType DDefs (TyOf (E1Ext () Ty1))
_ddefs Env2 (TyOf (E1Ext () Ty1))
env2 E1Ext () Ty1
ext =
    case E1Ext () Ty1
ext of
      BenchE Var
fn [()]
_ [PreExp E1Ext () Ty1]
_ Bool
_ -> ArrowTy (TyOf (E1Ext () Ty1)) -> TyOf (E1Ext () Ty1)
forall ty. FunctionTy ty => ArrowTy ty -> ty
outTy (ArrowTy (TyOf (E1Ext () Ty1)) -> TyOf (E1Ext () Ty1))
-> ArrowTy (TyOf (E1Ext () Ty1)) -> TyOf (E1Ext () Ty1)
forall a b. (a -> b) -> a -> b
$ Env2 Ty1 -> TyEnv (ArrowTy Ty1)
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf (E1Ext () Ty1))
Env2 Ty1
env2 Map Var ([Ty1], Ty1) -> Var -> ([Ty1], Ty1)
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
fn
      AddFixed Var
v Int
_i   -> if Var -> Map Var Ty1 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Var
v (Env2 Ty1 -> Map Var Ty1
forall a. Env2 a -> TyEnv a
vEnv Env2 (TyOf (E1Ext () Ty1))
Env2 Ty1
env2)
                         then TyOf (E1Ext () Ty1)
Ty1
forall loc. UrTy loc
CursorTy
                         else String -> TyOf (E1Ext () Ty1)
forall a. HasCallStack => String -> a
error (String -> TyOf (E1Ext () Ty1)) -> String -> TyOf (E1Ext () Ty1)
forall a b. (a -> b) -> a -> b
$ String
"AddFixed: unbound variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Show a => a -> String
show Var
v
      StartOfPkdCursor Var
cur ->
                         case Var -> Map Var Ty1 -> Maybe Ty1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
cur (Env2 Ty1 -> Map Var Ty1
forall a. Env2 a -> TyEnv a
vEnv Env2 (TyOf (E1Ext () Ty1))
Env2 Ty1
env2) of
                           Just (PackedTy{}) -> TyOf (E1Ext () Ty1)
Ty1
forall loc. UrTy loc
CursorTy
                           Maybe Ty1
ty -> String -> TyOf (E1Ext () Ty1)
forall a. HasCallStack => String -> a
error (String -> TyOf (E1Ext () Ty1)) -> String -> TyOf (E1Ext () Ty1)
forall a b. (a -> b) -> a -> b
$ String
"StartOfPkdCursor: got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Ty1 -> String
forall a. Show a => a -> String
show Maybe Ty1
ty

instance Renamable () where
    gRename :: Map Var Var -> () -> ()
gRename Map Var Var
_ () = ()

instance HasRenamable E1Ext l d => Renamable (E1Ext l d) where
  gRename :: Map Var Var -> E1Ext l d -> E1Ext l d
gRename Map Var Var
env E1Ext l d
ext =
    case E1Ext l d
ext of
      BenchE Var
fn [l]
tyapps [PreExp E1Ext l d]
args Bool
b -> Var -> [l] -> [PreExp E1Ext l d] -> Bool -> E1Ext l d
forall loc dec.
Var -> [loc] -> [PreExp E1Ext loc dec] -> Bool -> E1Ext loc dec
BenchE Var
fn [l]
tyapps ((PreExp E1Ext l d -> PreExp E1Ext l d)
-> [PreExp E1Ext l d] -> [PreExp E1Ext l d]
forall a b. (a -> b) -> [a] -> [b]
map PreExp E1Ext l d -> PreExp E1Ext l d
forall a. Renamable a => a -> a
go [PreExp E1Ext l d]
args) Bool
b
      AddFixed Var
v Int
i -> Var -> Int -> E1Ext l d
forall loc dec. Var -> Int -> E1Ext loc dec
AddFixed (Var -> Var
forall a. Renamable a => a -> a
go Var
v) Int
i
      StartOfPkdCursor Var
cur -> Var -> E1Ext l d
forall loc dec. Var -> E1Ext loc dec
StartOfPkdCursor (Var -> Var
forall a. Renamable a => a -> a
go Var
cur)
    where
      go :: forall a. Renamable a => a -> a
      go :: forall a. Renamable a => a -> a
go = Map Var Var -> a -> a
forall e. Renamable e => Map Var Var -> e -> e
gRename Map Var Var
env