{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE QuasiQuotes        #-}
{-# LANGUAGE TemplateHaskell    #-}

-- | The final pass of the compiler: generate C code.

module Gibbon.Passes.Codegen
  ( codegenProg, harvestStructTys, makeName, rewriteReturns ) where

import           Control.Monad
import           Data.Bifunctor (first)
import           Data.Int
import           Data.Loc
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.List as L
import qualified Data.Set as S
import           Language.C.Quote.C (cdecl, cedecl, cexp, cfun, cparam, csdecl, cstm, cty)
import qualified Language.C.Quote.C as C
import qualified Language.C.Syntax as C
import           Prelude hiding (init)
import           Text.PrettyPrint.Mainland
import           Text.PrettyPrint.Mainland.Class

import           Gibbon.Common
import qualified Gibbon.Language as GL
import           Gibbon.DynFlags
import           Gibbon.L2.Syntax ( Multiplicity(..) )
import           Gibbon.L4.Syntax

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


-- | Harvest all struct tys.  All product types used anywhere in the program.
harvestStructTys :: Prog -> S.Set [Ty]
harvestStructTys :: Prog -> Set [Ty]
harvestStructTys (Prog InfoTable
_ SymTable
_ [FunDecl]
funs Maybe MainExp
mtal) =
    [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => a -> Set a -> Set a
S.delete [] (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$
    ([Ty] -> [Ty]) -> Set [Ty] -> Set [Ty]
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (\[Ty]
tys -> (Ty -> Bool) -> [Ty] -> [Ty]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Ty
ty -> Ty
ty Ty -> Ty -> Bool
forall a. Eq a => a -> a -> Bool
/= ([Ty] -> Ty
ProdTy [])) [Ty]
tys) (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$
    (Set [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => Set a -> Set a -> Set a
S.union Set [Ty]
tys0 Set [Ty]
tys1)
  where
  tys00 :: [Ty]
tys00 = (Tail -> [Ty]) -> [Tail] -> [Ty]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tail -> [Ty]
allTypes [Tail]
allTails

  tys0 :: S.Set [Ty]
  tys0 :: Set [Ty]
tys0 = [Ty] -> Set [Ty]
findAllProds [Ty]
tys00

  tys1 :: S.Set [Ty]
  -- All types mentioned in function arguments and returns:
  tys1 :: Set [Ty]
tys1 = [[Ty]] -> Set [Ty]
forall a. Ord a => [a] -> Set a
S.fromList [ [Ty]
tys | FunDecl
fn <- [FunDecl]
funs, ProdTy [Ty]
tys <- FunDecl -> [Ty]
funTys FunDecl
fn ]
  -- structs f = makeStructs $ S.toList $ harvestStructTys prg

  funTys :: FunDecl -> [Ty]
  funTys :: FunDecl -> [Ty]
funTys (FunDecl Var
_ [(Var, Ty)]
args Ty
ty Tail
_ Bool
_) = Ty
ty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
args)

  allTails :: [Tail]
allTails = (case Maybe MainExp
mtal of
                Just (PrintExp Tail
t) -> [Tail
t]
                Maybe MainExp
Nothing -> []) [Tail] -> [Tail] -> [Tail]
forall a. [a] -> [a] -> [a]
++
             (FunDecl -> Tail) -> [FunDecl] -> [Tail]
forall a b. (a -> b) -> [a] -> [b]
map FunDecl -> Tail
funBody [FunDecl]
funs

  -- We may have nested products; this finds everything:
  findAllProds :: [Ty] -> S.Set [Ty]
  findAllProds :: [Ty] -> Set [Ty]
findAllProds = [Ty] -> Set [Ty]
go
    where
      go :: [Ty] -> Set [Ty]
go []     = Set [Ty]
forall a. Set a
S.empty
      go (Ty
t:[Ty]
ts) =
       case Ty
t of
         ProdTy [] -> [Ty] -> Set [Ty]
go [Ty]
ts
         ProdTy [Ty]
ls -> [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => a -> Set a -> Set a
S.insert [Ty]
ls (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$ Set [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Ty] -> Set [Ty]
go [Ty]
ls) ([Ty] -> Set [Ty]
go [Ty]
ts)
         VectorTy Ty
ty -> [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => a -> Set a -> Set a
S.insert [Ty -> Ty
VectorTy Ty
ty] (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$ Set [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Ty] -> Set [Ty]
go [Ty
ty])([Ty] -> Set [Ty]
go [Ty]
ts)
         ListTy Ty
ty -> [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => a -> Set a -> Set a
S.insert [Ty -> Ty
ListTy Ty
ty] (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$ Set [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Ty] -> Set [Ty]
go [Ty
ty])([Ty] -> Set [Ty]
go [Ty]
ts)
         PDictTy Ty
k Ty
v -> [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => a -> Set a -> Set a
S.insert [Ty -> Ty -> Ty
PDictTy Ty
k Ty
v] (Set [Ty] -> Set [Ty]) -> Set [Ty] -> Set [Ty]
forall a b. (a -> b) -> a -> b
$ Set [Ty] -> Set [Ty] -> Set [Ty]
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Ty] -> Set [Ty]
go [Ty
k, Ty
v]) ([Ty] -> Set [Ty]
go [Ty]
ts)
         Ty
_ -> [Ty] -> Set [Ty]
go [Ty]
ts

  -- This finds all types that maybe grouped together as a ProdTy:
  allTypes :: Tail -> [Ty]
  allTypes :: Tail -> [Ty]
allTypes = Tail -> [Ty]
go
   where
    go :: Tail -> [Ty]
go Tail
tl =
     case Tail
tl of
       Tail
EndOfMain -> []
       (RetValsT [Triv]
_)  -> []
       (AssnValsT [(Var, Ty, Triv)]
ls Maybe Tail
bod_maybe) ->
         case Maybe Tail
bod_maybe of
           Just Tail
bod -> [Ty] -> Ty
ProdTy (((Var, Ty, Triv) -> Ty) -> [(Var, Ty, Triv)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
_,Ty
x,Triv
_) -> Ty
x) [(Var, Ty, Triv)]
ls) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod
           Maybe Tail
Nothing  -> [[Ty] -> Ty
ProdTy (((Var, Ty, Triv) -> Ty) -> [(Var, Ty, Triv)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
_,Ty
x,Triv
_) -> Ty
x) [(Var, Ty, Triv)]
ls)]
       -- This creates a demand for a struct return, but it is covered
       -- by the fun signatures already:
       (LetCallT Bool
_ [(Var, Ty)]
binds Var
_ [Triv]
_  Tail
bod) -> [Ty] -> Ty
ProdTy (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
binds) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod
       -- INVARIANT: This does not create a struct:
       -- But just in case it does in the future, we add it:
       (LetPrimCallT [(Var, Ty)]
binds Prim
prm [Triv]
_ Tail
bod) ->
         let rst :: [Ty]
rst = Tail -> [Ty]
go Tail
bod in
         case Prim
prm of
           VAllocP Ty
elty  -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VFreeP Ty
elty   -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VFree2P Ty
elty  -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VLengthP Ty
elty -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VNthP   Ty
elty  -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VSliceP Ty
elty  -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           InplaceVUpdateP Ty
elty -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VConcatP Ty
elty -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VSortP Ty
elty   -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           InplaceVSortP Ty
_elty  -> Ty
voidTy Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           VMergeP Ty
elty -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLAllocP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLIsEmptyP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLConsP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLHeadP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLTailP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLFreeP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLFree2P Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           LLCopyP Ty
elty -> Ty -> Ty
ListTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictAllocP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictInsertP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictLookupP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictHasKeyP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictForkP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           PDictJoinP Ty
k Ty
v -> Ty -> Ty -> Ty
PDictTy Ty
k Ty
v Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           ReadArrayFile Maybe (FilePath, Int)
_ Ty
elty -> Ty -> Ty
VectorTy Ty
elty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
           Prim
_ -> [Ty] -> Ty
ProdTy (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
binds) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
rst
       (LetTrivT (Var
_,Ty
ty,Triv
_) Tail
bod)     -> Ty
ty Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod
       -- This should not create a struct.  Again, we add it just for the heck of it:
       (LetIfT [(Var, Ty)]
binds (Triv
_,Tail
a,Tail
b) Tail
bod)  -> [Ty] -> Ty
ProdTy (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
binds) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
a [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ Tail -> [Ty]
go Tail
b [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ Tail -> [Ty]
go Tail
bod
       (LetTimedT Bool
_ [(Var, Ty)]
binds Tail
rhs Tail
bod) -> [Ty] -> Ty
ProdTy (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
binds) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
rhs [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ Tail -> [Ty]
go Tail
bod
       (LetArenaT Var
_ Tail
bod)          -> [Ty] -> Ty
ProdTy [Ty
ArenaTy] Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod

       -- These are precisely for operating on structs:
       (LetUnpackT [(Var, Ty)]
binds Var
_ Tail
bod)    -> [Ty] -> Ty
ProdTy (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
binds) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod
       (LetAllocT Var
_ [(Ty, Triv)]
vals Tail
bod)      -> [Ty] -> Ty
ProdTy (((Ty, Triv) -> Ty) -> [(Ty, Triv)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Ty, Triv) -> Ty
forall a b. (a, b) -> a
fst [(Ty, Triv)]
vals) Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: Tail -> [Ty]
go Tail
bod
       (LetAvailT [Var]
_ Tail
bod)           -> Tail -> [Ty]
go Tail
bod

       (IfT Triv
_ Tail
a Tail
b) -> Tail -> [Ty]
go Tail
a [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ Tail -> [Ty]
go Tail
b
       ErrT{} -> []
       (Switch Var
_ Triv
_ (IntAlts [(Int64, Tail)]
ls) Maybe Tail
b) -> ((Int64, Tail) -> [Ty]) -> [(Int64, Tail)] -> [Ty]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Tail -> [Ty]
go (Tail -> [Ty]) -> ((Int64, Tail) -> Tail) -> (Int64, Tail) -> [Ty]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64, Tail) -> Tail
forall a b. (a, b) -> b
snd) [(Int64, Tail)]
ls [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ (Tail -> [Ty]) -> [Tail] -> [Ty]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tail -> [Ty]
go (Maybe Tail -> [Tail]
forall a. Maybe a -> [a]
maybeToList Maybe Tail
b)
       (Switch Var
_ Triv
_ (TagAlts [(Tag, Tail)]
ls) Maybe Tail
b) -> ((Tag, Tail) -> [Ty]) -> [(Tag, Tail)] -> [Ty]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Tail -> [Ty]
go (Tail -> [Ty]) -> ((Tag, Tail) -> Tail) -> (Tag, Tail) -> [Ty]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag, Tail) -> Tail
forall a b. (a, b) -> b
snd) [(Tag, Tail)]
ls [Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++ (Tail -> [Ty]) -> [Tail] -> [Ty]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tail -> [Ty]
go (Maybe Tail -> [Tail]
forall a. Maybe a -> [a]
maybeToList Maybe Tail
b)
       (TailCall Var
_ [Triv]
_)    -> []
       (Goto Var
_) -> []

sortFns :: Prog -> S.Set Var
sortFns :: Prog -> Set Var
sortFns (Prog InfoTable
_ SymTable
_ [FunDecl]
funs Maybe MainExp
mtal) = (Set Var -> Tail -> Set Var) -> Set Var -> [Tail] -> Set Var
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set Var -> Tail -> Set Var
go Set Var
forall a. Set a
S.empty [Tail]
allTails
  where
    allTails :: [Tail]
allTails = (case Maybe MainExp
mtal of
                Just (PrintExp Tail
t) -> [Tail
t]
                Maybe MainExp
Nothing -> []) [Tail] -> [Tail] -> [Tail]
forall a. [a] -> [a] -> [a]
++
             (FunDecl -> Tail) -> [FunDecl] -> [Tail]
forall a b. (a -> b) -> [a] -> [b]
map FunDecl -> Tail
funBody [FunDecl]
funs

    go :: Set Var -> Tail -> Set Var
go Set Var
acc Tail
tl =
      case Tail
tl of
        Tail
EndOfMain -> Set Var
acc
        RetValsT{} -> Set Var
acc
        AssnValsT [(Var, Ty, Triv)]
_ Maybe Tail
mb_bod -> case Maybe Tail
mb_bod of
                                Just Tail
bod -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
                                Maybe Tail
Nothing  -> Set Var
acc
        LetCallT{Tail
bod :: Tail
bod :: Tail -> Tail
bod} -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        LetPrimCallT{Prim
prim :: Prim
prim :: Tail -> Prim
prim,Tail
bod :: Tail -> Tail
bod :: Tail
bod,[Triv]
rands :: [Triv]
rands :: Tail -> [Triv]
rands} ->
          case Prim
prim of
            VSortP{} ->
              let [Triv
_,VarTriv Var
fp] = [Triv]
rands
              in Set Var -> Tail -> Set Var
go (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
fp Set Var
acc) Tail
bod
            InplaceVSortP{} ->
              let [Triv
_,VarTriv Var
fp] = [Triv]
rands
              in Set Var -> Tail -> Set Var
go (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
fp Set Var
acc) Tail
bod
            Prim
_ -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        LetTrivT{Tail
bod :: Tail -> Tail
bod :: Tail
bod}   -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        LetIfT{(Triv, Tail, Tail)
ife :: (Triv, Tail, Tail)
ife :: Tail -> (Triv, Tail, Tail)
ife,Tail
bod :: Tail -> Tail
bod :: Tail
bod} ->
          let (Triv
_,Tail
a,Tail
b) = (Triv, Tail, Tail)
ife
          in Set Var -> Tail -> Set Var
go (Set Var -> Tail -> Set Var
go (Set Var -> Tail -> Set Var
go Set Var
acc Tail
a) Tail
b) Tail
bod
        LetUnpackT{Tail
bod :: Tail -> Tail
bod :: Tail
bod} -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        LetAllocT{Tail
bod :: Tail -> Tail
bod :: Tail
bod}  -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        LetAvailT{Tail
bod :: Tail -> Tail
bod :: Tail
bod}  -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod
        IfT{Tail
con :: Tail
con :: Tail -> Tail
con,Tail
els :: Tail
els :: Tail -> Tail
els}    -> Set Var -> Tail -> Set Var
go (Set Var -> Tail -> Set Var
go Set Var
acc Tail
con) Tail
els
        ErrT{} -> Set Var
acc
        LetTimedT{Tail
timed :: Tail
timed :: Tail -> Tail
timed,Tail
bod :: Tail -> Tail
bod :: Tail
bod} -> Set Var -> Tail -> Set Var
go (Set Var -> Tail -> Set Var
go Set Var
acc Tail
timed) Tail
bod
        Switch Var
_ Triv
_ Alts
alts Maybe Tail
mb_tl ->
          let acc1 :: Set Var
acc1 = case Maybe Tail
mb_tl of
                       Maybe Tail
Nothing -> Set Var
acc
                       Just Tail
tl -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
tl
          in case Alts
alts of
               TagAlts [(Tag, Tail)]
ls -> ((Tag, Tail) -> Set Var -> Set Var)
-> Set Var -> [(Tag, Tail)] -> Set Var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Tag
_,Tail
b) Set Var
ac -> Set Var -> Tail -> Set Var
go Set Var
ac Tail
b) Set Var
acc1 [(Tag, Tail)]
ls
               IntAlts [(Int64, Tail)]
ls -> ((Int64, Tail) -> Set Var -> Set Var)
-> Set Var -> [(Int64, Tail)] -> Set Var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int64
_,Tail
b) Set Var
ac -> Set Var -> Tail -> Set Var
go Set Var
ac Tail
b) Set Var
acc1 [(Int64, Tail)]
ls
        TailCall{}     -> Set Var
acc
        Goto{}         -> Set Var
acc
        LetArenaT{Tail
bod :: Tail -> Tail
bod :: Tail
bod} -> Set Var -> Tail -> Set Var
go Set Var
acc Tail
bod

--------------------------------------------------------------------------------
-- * C codegen

-- | Compile a program to C code that has the side effect of the
-- "gibbon_main" expression in that program.
codegenProg :: Config -> Prog -> IO String
codegenProg :: Config -> Prog -> IO FilePath
codegenProg Config
cfg prg :: Prog
prg@(Prog InfoTable
info_tbl SymTable
sym_tbl [FunDecl]
funs Maybe MainExp
mtal) =
      FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
hashIncludes FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> Doc -> FilePath
pretty Int
80 ([Doc] -> Doc
stack ((Definition -> Doc) -> [Definition] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Doc
forall a. Pretty a => a -> Doc
ppr [Definition]
defs)))
    where
      init_fun_env :: Map Var ([Ty], Ty)
init_fun_env = (FunDecl -> Map Var ([Ty], Ty) -> Map Var ([Ty], Ty))
-> Map Var ([Ty], Ty) -> [FunDecl] -> Map Var ([Ty], Ty)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\FunDecl
fn Map Var ([Ty], Ty)
acc -> Var -> ([Ty], Ty) -> Map Var ([Ty], Ty) -> Map Var ([Ty], Ty)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDecl -> Var
funName FunDecl
fn) (((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd (FunDecl -> [(Var, Ty)]
funArgs FunDecl
fn), FunDecl -> Ty
funRetTy FunDecl
fn) Map Var ([Ty], Ty)
acc) Map Var ([Ty], Ty)
forall k a. Map k a
M.empty [FunDecl]
funs

      sort_fns :: Set Var
sort_fns = Prog -> Set Var
sortFns Prog
prg

      defs :: [Definition]
defs = ([Definition], Int) -> [Definition]
forall a b. (a, b) -> a
fst (([Definition], Int) -> [Definition])
-> ([Definition], Int) -> [Definition]
forall a b. (a -> b) -> a -> b
$ Config -> Int -> PassM [Definition] -> ([Definition], Int)
forall a. Config -> Int -> PassM a -> (a, Int)
runPassM Config
cfg Int
0 (PassM [Definition] -> ([Definition], Int))
-> PassM [Definition] -> ([Definition], Int)
forall a b. (a -> b) -> a -> b
$ do
        ([Definition]
prots,[Definition]
funs') <- ([(Definition, Definition)] -> ([Definition], [Definition])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Definition, Definition)] -> ([Definition], [Definition]))
-> ([[(Definition, Definition)]] -> [(Definition, Definition)])
-> [[(Definition, Definition)]]
-> ([Definition], [Definition])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Definition, Definition)]] -> [(Definition, Definition)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([[(Definition, Definition)]] -> ([Definition], [Definition]))
-> PassM [[(Definition, Definition)]]
-> PassM ([Definition], [Definition])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FunDecl -> PassM [(Definition, Definition)])
-> [FunDecl] -> PassM [[(Definition, Definition)]]
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) -> [a] -> m [b]
mapM FunDecl -> PassM [(Definition, Definition)]
codegenFun [FunDecl]
funs
        Definition
main_expr' <- PassM Definition
main_expr
        let struct_tys :: [[Ty]]
struct_tys = [[Ty]] -> [[Ty]]
uniqueDicts ([[Ty]] -> [[Ty]]) -> [[Ty]] -> [[Ty]]
forall a b. (a -> b) -> a -> b
$ Set [Ty] -> [[Ty]]
forall a. Set a -> [a]
S.toList (Set [Ty] -> [[Ty]]) -> Set [Ty] -> [[Ty]]
forall a b. (a -> b) -> a -> b
$ Prog -> Set [Ty]
harvestStructTys Prog
prg
        [Definition] -> PassM [Definition]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Definition] -> [Definition]
forall a. Eq a => [a] -> [a]
L.nub ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ [[Ty]] -> [Definition]
makeStructs [[Ty]]
struct_tys) [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
prots [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++
                [Definition
gibTypesEnum, InfoTable -> Definition
initInfoTable InfoTable
info_tbl, SymTable -> Definition
initSymTable SymTable
sym_tbl] [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++
                [Definition]
funs' [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition
main_expr'])

      main_expr :: PassM C.Definition
      main_expr :: PassM Definition
main_expr = do
        DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
        let pointer :: Bool
pointer = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pointer DynFlags
dflags
        let gen_gc :: Bool
gen_gc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenGc DynFlags
dflags
        [BlockItem]
e <- case Maybe MainExp
mtal of
               -- [2019.06.13]: CSK, Why is codegenTail always called with IntTy?
               Just (PrintExp Tail
t) -> VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
forall k a. Map k a
M.empty Map Var ([Ty], Ty)
init_fun_env Set Var
sort_fns Tail
t Ty
IntTy []
               Maybe MainExp
_ -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Var
ret_init <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"init"
        Var
ret_exit <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"exit"
        let init_gib :: [BlockItem]
init_gib = (if Bool
pointer then [ Stm -> BlockItem
C.BlockStm [cstm| GC_INIT(); |] ] else []) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                       [ InitGroup -> BlockItem
C.BlockDecl [cdecl| int $id:ret_init = gib_init(argc, argv); |] ]
            exit_gib :: [BlockItem]
exit_gib = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| int $id:ret_exit = gib_exit(); |]
                       , Stm -> BlockItem
C.BlockStm [cstm| return $id:ret_exit; |]
                       ]
            init_info_table :: [BlockItem]
init_info_table = [ Stm -> BlockItem
C.BlockStm [cstm| info_table_initialize(); |] ]
            init_symbol_table :: [BlockItem]
init_symbol_table = [ Stm -> BlockItem
C.BlockStm [cstm| symbol_table_initialize(); |] ]
        let bod :: [BlockItem]
bod = [BlockItem]
init_gib [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
init_info_table [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
init_symbol_table
                  [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ (if Bool
gen_gc then [BlockItem]
ssDecls else [])
                  [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
e [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
exit_gib
        Definition -> PassM Definition
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Definition -> PassM Definition) -> Definition -> PassM Definition
forall a b. (a -> b) -> a -> b
$ Func -> SrcLoc -> Definition
C.FuncDef [cfun| int main(int argc, char **argv) { $items:bod } |] SrcLoc
forall a. IsLocation a => a
noLoc

      codegenFun' :: FunDecl -> PassM C.Func
      codegenFun' :: FunDecl -> PassM Func
codegenFun' (FunDecl Var
nam [(Var, Ty)]
args Ty
ty Tail
tal Bool
_) =
          do DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
             let gen_gc :: Bool
gen_gc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenGc DynFlags
dflags
             let retTy :: Type
retTy   = Ty -> Type
codegenTy Ty
ty
                 params :: [Param]
params  = ((Var, Ty) -> Param) -> [(Var, Ty)] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,Ty
t) -> [cparam| $ty:(codegenTy t) $id:v |]) [(Var, Ty)]
args
                 init_venv :: VEnv
init_venv = [(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
args
             let nam' :: Var
nam' = if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
nam Set Var
sort_fns
                        then Var -> Var -> Var
varAppend Var
nam (FilePath -> Var
toVar FilePath
"_original")
                        else Var
nam
             [BlockItem]
body <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
init_venv Map Var ([Ty], Ty)
init_fun_env Set Var
sort_fns Tail
tal Ty
ty []
             let body' :: [BlockItem]
body' = (if Bool
gen_gc then [BlockItem]
ssDecls else []) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
body
             let fun :: Func
fun = [cfun| $ty:retTy $id:nam' ($params:params) {
                              $items:body'
                              } |]
             Func -> PassM Func
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Func
fun

      -- C's qsort expects a sort function to be of type, (void*  a, void* b) : int.
      -- But there's no way for a user to write a function of this type. So we generate
      -- the function that the user wrote with a different_name, and then codegenSortFn
      -- generates the actual sort function; which reads the values from these void*
      -- pointers and calls the user written one after that.
      codegenSortFn :: FunDecl -> PassM C.Func
      codegenSortFn :: FunDecl -> PassM Func
codegenSortFn (FunDecl Var
nam [(Var, Ty)]
args Ty
_ty Tail
_tal Bool
_) = do
        let nam' :: Var
nam' = Var -> Var -> Var
varAppend Var
nam (FilePath -> Var
toVar FilePath
"_original")
            ([Var
v0,Var
v1],[Ty
ty0,Ty
ty1]) = [(Var, Ty)] -> ([Var], [Ty])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty)]
args
            params :: [Param]
params     = (Var -> Param) -> [Var] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
v -> [cparam| const void* $id:v |]) [Var
v0,Var
v1]
        Var
tmpa <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"fst"
        Var
tmpb <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"snd"
        let bod :: [BlockItem]
bod = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:tmpa = *($ty:(codegenTy ty0) *) $id:v0; |]
                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty1) $id:tmpb = *($ty:(codegenTy ty1) *) $id:v1; |]
                  , Stm -> BlockItem
C.BlockStm  [cstm| return $id:nam'($id:tmpa, $id:tmpb);|]
                  ]
            fun :: Func
fun = [cfun| int $id:nam ($params:params) {
                          $items:bod
                       } |]
        Func -> PassM Func
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Func
fun

      makeProt :: C.Func -> Bool -> PassM C.InitGroup
      makeProt :: Func -> Bool -> PassM InitGroup
makeProt Func
fn Bool
_ispure = do
        DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
        let prot :: InitGroup
prot@(C.InitGroup DeclSpec
_decl_spec [Attr]
_ [Init]
_inits SrcLoc
_lc) = Func -> InitGroup
C.funcProto Func
fn
            _purattr :: Attr
_purattr = Id -> [Exp] -> SrcLoc -> Attr
C.Attr (FilePath -> SrcLoc -> Id
C.Id FilePath
"pure" SrcLoc
forall a. IsLocation a => a
noLoc) [] SrcLoc
forall a. IsLocation a => a
noLoc
            -- Only add pure annotations if compiling in pointer mode, and if the
            -- --no-pure-annot flag is not passed.
            _pureAnnotOk :: Bool
_pureAnnotOk = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_No_PureAnnot DynFlags
dflags Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Packed DynFlags
dflags)
        -- if ispure && pureAnnotOk
        -- then return $ C.InitGroup decl_spec [purattr] inits lc
        -- else return prot
        InitGroup -> PassM InitGroup
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return InitGroup
prot

      codegenFun :: FunDecl -> PassM [(C.Definition, C.Definition)]
      codegenFun :: FunDecl -> PassM [(Definition, Definition)]
codegenFun fd :: FunDecl
fd@FunDecl{Var
funName :: FunDecl -> Var
funName :: Var
funName} =
          do Func
fun <- FunDecl -> PassM Func
codegenFun' FunDecl
fd
             InitGroup
prot <- Func -> Bool -> PassM InitGroup
makeProt Func
fun (FunDecl -> Bool
isPure FunDecl
fd)
             [(Definition, Definition)]
sort_fn <- if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
funName Set Var
sort_fns
                        then do
                          Func
fun' <- FunDecl -> PassM Func
codegenSortFn FunDecl
fd
                          let prot :: InitGroup
prot = Func -> InitGroup
C.funcProto Func
fun'
                          [(Definition, Definition)] -> PassM [(Definition, Definition)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(InitGroup -> SrcLoc -> Definition
C.DecDef InitGroup
prot SrcLoc
forall a. IsLocation a => a
noLoc, Func -> SrcLoc -> Definition
C.FuncDef Func
fun' SrcLoc
forall a. IsLocation a => a
noLoc)]
                        else [(Definition, Definition)] -> PassM [(Definition, Definition)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
             [(Definition, Definition)] -> PassM [(Definition, Definition)]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Definition, Definition)] -> PassM [(Definition, Definition)])
-> [(Definition, Definition)] -> PassM [(Definition, Definition)]
forall a b. (a -> b) -> a -> b
$ [(InitGroup -> SrcLoc -> Definition
C.DecDef InitGroup
prot SrcLoc
forall a. IsLocation a => a
noLoc, Func -> SrcLoc -> Definition
C.FuncDef Func
fun SrcLoc
forall a. IsLocation a => a
noLoc)] [(Definition, Definition)]
-> [(Definition, Definition)] -> [(Definition, Definition)]
forall a. [a] -> [a] -> [a]
++ [(Definition, Definition)]
sort_fn

      gibTypesEnum :: Definition
gibTypesEnum =
        let go :: FilePath -> CEnum
go FilePath
str = Id -> Maybe Exp -> SrcLoc -> CEnum
C.CEnum (FilePath -> SrcLoc -> Id
C.Id (FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T") SrcLoc
forall a. IsLocation a => a
noLoc) Maybe Exp
forall a. Maybe a
Nothing SrcLoc
forall a. IsLocation a => a
noLoc
            decls :: [CEnum]
decls = (FilePath -> CEnum) -> [FilePath] -> [CEnum]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CEnum
go ([FilePath]
builtinFieldTys [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ InfoTable -> [FilePath]
forall k a. Map k a -> [k]
M.keys InfoTable
info_tbl)
        in [cedecl| typedef enum { $enums:decls } GibDatatype; |]

      hashIncludes :: FilePath
hashIncludes =
        FilePath
"/* Gibbon program. */\n\n\
        \#include \"gibbon_rts.h\"\n\n\
        \#include <assert.h>\n\
        \#include <stdio.h>\n\
        \#include <stdlib.h>\n\
        \#include <stdint.h>\n\
        \#include <inttypes.h>\n\
        \#include <math.h>\n\
        \#include <stdbool.h>\n\
        \#include <string.h>\n\
        \#include <time.h>\n\
        \#include <alloca.h>\n\
        \#include <sys/mman.h>\n\
        \#include <sys/resource.h>\n\
        \#include <sys/stat.h>\n\
        \#include <unistd.h>\n\
        \#include <fcntl.h>\n\
        \#include <stdarg.h>\n\
        \#include <errno.h>\n\
        \#include <uthash.h>\n\n\
        \#ifdef _WIN64\n\
        \#include <windows.h>\n\
        \#endif\n\n\
        \#ifdef _GIBBON_POINTER\n\
        \#include <gc.h>\n\
        \#endif\n\n\
        \#ifdef _GIBBON_PARALLEL\n\
        \#include <cilk/cilk.h>\n\
        \#include <cilk/cilk_api.h>\n\
        \#endif\n\n\
        \/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\
        \ * Program starts here\n\
        \ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\
        \ */\n\n"


builtinFieldTys :: [String]
builtinFieldTys :: [FilePath]
builtinFieldTys =
    [ FilePath
"GibInt", FilePath
"GibFloat", FilePath
"GibSym", FilePath
"GibBool", FilePath
"GibVector", FilePath
"GibList", FilePath
"GibCursor"
    -- , "GibPackedTag", "GibBoxedTag", "GibPtr", "GibSymDict", "GibSymSet"
    -- , "GibSymHash", "GibIntHash"
    ]

initSymTable :: SymTable -> C.Definition
initSymTable :: SymTable -> Definition
initSymTable SymTable
sym_tbl =
    let body :: [BlockItem]
body =  ((Word16, FilePath) -> BlockItem)
-> [(Word16, FilePath)] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(Word16
k,FilePath
v) -> case FilePath
v of
                       -- Special symbols that get handled differently
                       FilePath
"NEWLINE" -> Stm -> BlockItem
C.BlockStm [cstm| gib_set_newline($k); |]
                       FilePath
"COMMA" -> Stm -> BlockItem
C.BlockStm [cstm| set_comma($k); |]
                       FilePath
"SPACE" -> Stm -> BlockItem
C.BlockStm [cstm| gib_set_space($k); |]
                       FilePath
"LEFTPAREN" -> Stm -> BlockItem
C.BlockStm [cstm| gib_set_leftparen($k); |]
                       FilePath
"RIGHTPAREN" -> Stm -> BlockItem
C.BlockStm [cstm| gib_set_rightparen($k); |]
                       -- Normal symbols just get added to the table
                       FilePath
_ -> Stm -> BlockItem
C.BlockStm [cstm| gib_add_symbol($k, $v); |]
          )
          (SymTable -> [(Word16, FilePath)]
forall k a. Map k a -> [(k, a)]
M.toList SymTable
sym_tbl)
        fun :: Func
fun = [cfun| void symbol_table_initialize(void) { $items:body } |]
    in Func -> SrcLoc -> Definition
C.FuncDef Func
fun SrcLoc
forall a. IsLocation a => a
noLoc


initInfoTable :: InfoTable -> C.Definition
initInfoTable :: InfoTable -> Definition
initInfoTable InfoTable
info_tbl =
    let info_table_len :: Int
info_table_len = InfoTable -> Int
forall a. Map FilePath a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length InfoTable
info_tbl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
builtinFieldTys
        body :: [BlockItem]
body =  [ InitGroup -> BlockItem
C.BlockDecl [cdecl| int error = gib_info_table_initialize($int:info_table_len); |]
                , Stm -> BlockItem
C.BlockStm [cstm| if (error < 0) { fprintf(stderr, "Couldn't initialize info table, errorno=%d", error); exit(1); } |]
                ]  [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                -- insert_scalar_info ++
                [ InitGroup -> BlockItem
C.BlockDecl [cdecl| typename GibDatatype field_tys[$int:max_fields]; |] ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
insert_dcon_info [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                [Stm -> BlockItem
C.BlockStm [cstm| gib_info_table_finalize(); |] ]
        fun :: Func
fun = [cfun| void info_table_initialize(void) { $items:body } |]
    in Func -> SrcLoc -> Definition
C.FuncDef Func
fun SrcLoc
forall a. IsLocation a => a
noLoc
  where
    max_fields :: Int
max_fields = (Map FilePath DataConInfo -> Int -> Int) -> Int -> InfoTable -> Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr (\Map FilePath DataConInfo
tyc_info Int
acc ->
                              Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
acc (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$
                                  (FilePath -> DataConInfo -> Int -> Int)
-> Int -> Map FilePath DataConInfo -> Int
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\FilePath
dcon DataConInfo{Int
num_scalars :: Int
num_scalars :: DataConInfo -> Int
num_scalars,Int
num_packed :: Int
num_packed :: DataConInfo -> Int
num_packed} Int
acc2 ->
                                                      if FilePath -> Bool
GL.isIndirectionTag FilePath
dcon then Int
acc2 else
                                                          (Int
num_scalars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num_packed) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
acc2)
                                                 Int
0
                                                 Map FilePath DataConInfo
tyc_info)
                         Int
0
                         InfoTable
info_tbl
    _insert_scalar_info :: [BlockItem]
_insert_scalar_info = (FilePath -> BlockItem) -> [FilePath] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
ty -> let ty_t :: FilePath
ty_t = FilePath
ty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T" in Stm -> BlockItem
C.BlockStm [cstm| gib_info_table_insert_scalar($id:ty_t, sizeof($id:ty)); |]) [FilePath]
builtinFieldTys

    insert_dcon_info :: [BlockItem]
insert_dcon_info = (FilePath
 -> Map FilePath DataConInfo -> [BlockItem] -> [BlockItem])
-> [BlockItem] -> InfoTable -> [BlockItem]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
                           (\FilePath
tycon Map FilePath DataConInfo
tyc_info [BlockItem]
acc ->
                                (FilePath -> DataConInfo -> [BlockItem] -> [BlockItem])
-> [BlockItem] -> Map FilePath DataConInfo -> [BlockItem]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\FilePath
dcon (DataConInfo Tag
dcon_tag Int
scalar_bytes Int
num_shortcut Int
num_scalars Int
num_packed [Ty3]
field_tys) [BlockItem]
acc2 ->
                                                    if FilePath -> Bool
GL.isIndirectionTag FilePath
dcon then [BlockItem]
acc2 else
                                                    let packed_field_tys :: [Ty3]
packed_field_tys = (Ty3 -> Bool) -> [Ty3] -> [Ty3]
forall a. (a -> Bool) -> [a] -> [a]
filter Ty3 -> Bool
forall a. UrTy a -> Bool
GL.isPackedTy [Ty3]
field_tys
                                                        set_field_tys :: [BlockItem]
set_field_tys =
                                                            ((Ty3, Integer) -> BlockItem) -> [(Ty3, Integer)] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ty3
ty,Integer
i) ->
                                                                     let ty' :: FilePath
ty' = (case Ty3
ty of
                                                                                    GL.PackedTy FilePath
tycon ()
_ -> FilePath
tycon
                                                                                    Ty3
_ -> Ty -> FilePath
makeName' (Ty3 -> Ty
fromL3Ty Ty3
ty))
                                                                               FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T"
                                                                         e :: Id
e = (FilePath -> SrcLoc -> Id
C.Id FilePath
ty' SrcLoc
forall a. IsLocation a => a
noLoc)
                                                                     in Stm -> BlockItem
C.BlockStm [cstm| field_tys[$int:i] = ($id:e); |])
                                                                ([Ty3] -> [Integer] -> [(Ty3, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ty3]
packed_field_tys [Integer
0..])
                                                        tycon' :: FilePath
tycon' = FilePath
tycon FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T"
                                                        insert_into_tbl :: [BlockItem]
insert_into_tbl = [ Stm -> BlockItem
C.BlockStm [cstm| error = gib_info_table_insert_packed_dcon($id:tycon', $int:dcon_tag, $int:scalar_bytes, $int:num_shortcut, $int:num_scalars, $int:num_packed, field_tys, $int:num_packed); |]
                                                                          , Stm -> BlockItem
C.BlockStm [cstm| if (error < 0) { fprintf(stderr, "Couldn't insert into info table, errorno=%d, tycon=%d, dcon=%d", error, $id:tycon', $int:dcon_tag); exit(1); } |] ]
                                             in [BlockItem]
set_field_tys [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
insert_into_tbl [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
acc2)
                                        [BlockItem]
acc
                                        Map FilePath DataConInfo
tyc_info)
                           []
                           InfoTable
info_tbl


makeStructs :: [[Ty]] -> [C.Definition]
makeStructs :: [[Ty]] -> [Definition]
makeStructs [] = []
makeStructs ([Ty]
ts : [[Ty]]
ts') =
      let strName :: FilePath
strName = [Ty] -> FilePath
makeName [Ty]
ts
          decls :: [FieldGroup]
decls = (Ty -> Int -> FieldGroup) -> [Ty] -> [Int] -> [FieldGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Ty
t Int
n -> [csdecl| $ty:(codegenTy t) $id:("field"++(show n)); |]) [Ty]
ts [Int
0 :: Int ..]
          d :: Definition
d = [cedecl| typedef struct $id:(strName ++ "_struct") { $sdecls:decls } $id:strName; |]
      in Definition
d Definition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
: [[Ty]] -> [Definition]
makeStructs [[Ty]]
ts'

uniqueDicts :: [[Ty]] -> [[Ty]]
uniqueDicts :: [[Ty]] -> [[Ty]]
uniqueDicts [] = []
uniqueDicts ([Ty]
ts : [[Ty]]
ts') = ((Ty -> Ty) -> [Ty] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map Ty -> Ty
f [Ty]
ts) [Ty] -> [[Ty]] -> [[Ty]]
forall a. a -> [a] -> [a]
: [[Ty]] -> [[Ty]]
uniqueDicts [[Ty]]
ts'
    where f :: Ty -> Ty
f (SymDictTy Var
_ Ty
t) = Var -> Ty -> Ty
SymDictTy Var
"_" Ty
t
          f Ty
t = Ty
t

-- | Replace returns with assignments to a given set of destinations.
rewriteReturns :: Tail -> [(Var,Ty)] -> Tail
rewriteReturns :: Tail -> [(Var, Ty)] -> Tail
rewriteReturns Tail
tl [(Var, Ty)]
bnds =
 let go :: Tail -> Tail
go Tail
x = Tail -> [(Var, Ty)] -> Tail
rewriteReturns Tail
x [(Var, Ty)]
bnds in
 case Tail
tl of
   Tail
EndOfMain -> Tail
tl
   (RetValsT [Triv]
ls) -> [(Var, Ty, Triv)] -> Maybe Tail -> Tail
AssnValsT [ (Var
v,Ty
t,Triv
e) | (Var
v,Ty
t) <- [(Var, Ty)]
bnds | Triv
e <- [Triv]
ls ] Maybe Tail
forall a. Maybe a
Nothing
   (Goto Var
_) -> Tail
tl

   -- Here we've already rewritten the tail to assign values
   -- somewhere.. and now we want to REREWRITE it?
   (AssnValsT [(Var, Ty, Triv)]
_ Maybe Tail
_) -> FilePath -> Tail
forall a. HasCallStack => FilePath -> a
error(FilePath -> Tail) -> FilePath -> Tail
forall a b. (a -> b) -> a -> b
$ FilePath
"rewriteReturns: Internal invariant broken:\n "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Tail -> FilePath
forall a. Out a => a -> FilePath
sdoc Tail
tl
   (e :: Tail
e@LetCallT{Tail
bod :: Tail -> Tail
bod :: Tail
bod})     -> Tail
e{bod :: Tail
bod = Tail -> Tail
go Tail
bod }
   (e :: Tail
e@LetPrimCallT{Tail
bod :: Tail -> Tail
bod :: Tail
bod}) -> Tail
e{bod :: Tail
bod = Tail -> Tail
go Tail
bod }
   (e :: Tail
e@LetTrivT{Tail
bod :: Tail -> Tail
bod :: Tail
bod})     -> Tail
e{bod :: Tail
bod = Tail -> Tail
go Tail
bod }
   -- We don't recur on the "tails" under the if, because they're not
   -- tail with respect to our redex:
   (LetIfT [(Var, Ty)]
bnd (Triv
a,Tail
b,Tail
c) Tail
bod) -> [(Var, Ty)] -> (Triv, Tail, Tail) -> Tail -> Tail
LetIfT [(Var, Ty)]
bnd (Triv
a,Tail
b,Tail
c) (Tail -> Tail
go Tail
bod)
   (LetTimedT Bool
flg [(Var, Ty)]
bnd Tail
rhs Tail
bod) -> Bool -> [(Var, Ty)] -> Tail -> Tail -> Tail
LetTimedT Bool
flg [(Var, Ty)]
bnd Tail
rhs (Tail -> Tail
go Tail
bod)
   (LetArenaT Var
v Tail
bod) -> Var -> Tail -> Tail
LetArenaT Var
v (Tail -> Tail
go Tail
bod)
   (LetUnpackT [(Var, Ty)]
bs Var
scrt Tail
body) -> [(Var, Ty)] -> Var -> Tail -> Tail
LetUnpackT [(Var, Ty)]
bs Var
scrt (Tail -> Tail
go Tail
body)
   (LetAllocT Var
lhs [(Ty, Triv)]
vals Tail
body) -> Var -> [(Ty, Triv)] -> Tail -> Tail
LetAllocT Var
lhs [(Ty, Triv)]
vals (Tail -> Tail
go Tail
body)
   (LetAvailT [Var]
vs Tail
body)       -> [Var] -> Tail -> Tail
LetAvailT [Var]
vs (Tail -> Tail
go Tail
body)
   (IfT Triv
a Tail
b Tail
c) -> Triv -> Tail -> Tail -> Tail
IfT Triv
a (Tail -> Tail
go Tail
b) (Tail -> Tail
go Tail
c)
   (ErrT FilePath
s) -> (FilePath -> Tail
ErrT FilePath
s)
   (Switch Var
lbl Triv
tr Alts
alts Maybe Tail
def) -> Var -> Triv -> Alts -> Maybe Tail -> Tail
Switch Var
lbl Triv
tr ((Tail -> Tail) -> Alts -> Alts
mapAlts Tail -> Tail
go Alts
alts) ((Tail -> Tail) -> Maybe Tail -> Maybe Tail
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tail -> Tail
go Maybe Tail
def)
   -- Oops, this is not REALLY a tail call.  Hoist it and go under:
   (TailCall Var
f [Triv]
rnds) -> let ([Var]
vs,[Ty]
ts) = [(Var, Ty)] -> ([Var], [Ty])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty)]
bnds
                            vs' :: [Var]
vs' = (FilePath -> Var) -> [FilePath] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Var
toVar (FilePath -> Var) -> (FilePath -> FilePath) -> FilePath -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"hack")) ((Var -> FilePath) -> [Var] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Var -> FilePath
fromVar [Var]
vs) -- FIXME: Gensym
                        in Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
LetCallT Bool
False ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs' [Ty]
ts) Var
f [Triv]
rnds
                            (Tail -> [(Var, Ty)] -> Tail
rewriteReturns ([Triv] -> Tail
RetValsT ((Var -> Triv) -> [Var] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Triv
VarTriv [Var]
vs')) [(Var, Ty)]
bnds)
 where
   mapAlts :: (Tail -> Tail) -> Alts -> Alts
mapAlts Tail -> Tail
f (TagAlts [(Tag, Tail)]
ls) = [(Tag, Tail)] -> Alts
TagAlts ([(Tag, Tail)] -> Alts) -> [(Tag, Tail)] -> Alts
forall a b. (a -> b) -> a -> b
$ [Tag] -> [Tail] -> [(Tag, Tail)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Tag, Tail) -> Tag) -> [(Tag, Tail)] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Tag, Tail) -> Tag
forall a b. (a, b) -> a
fst [(Tag, Tail)]
ls) (((Tag, Tail) -> Tail) -> [(Tag, Tail)] -> [Tail]
forall a b. (a -> b) -> [a] -> [b]
map (Tail -> Tail
f (Tail -> Tail) -> ((Tag, Tail) -> Tail) -> (Tag, Tail) -> Tail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag, Tail) -> Tail
forall a b. (a, b) -> b
snd) [(Tag, Tail)]
ls)
   mapAlts Tail -> Tail
f (IntAlts [(Int64, Tail)]
ls) = [(Int64, Tail)] -> Alts
IntAlts ([(Int64, Tail)] -> Alts) -> [(Int64, Tail)] -> Alts
forall a b. (a -> b) -> a -> b
$ [Int64] -> [Tail] -> [(Int64, Tail)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Int64, Tail) -> Int64) -> [(Int64, Tail)] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map (Int64, Tail) -> Int64
forall a b. (a, b) -> a
fst [(Int64, Tail)]
ls) (((Int64, Tail) -> Tail) -> [(Int64, Tail)] -> [Tail]
forall a b. (a -> b) -> [a] -> [b]
map (Tail -> Tail
f (Tail -> Tail) -> ((Int64, Tail) -> Tail) -> (Int64, Tail) -> Tail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64, Tail) -> Tail
forall a b. (a, b) -> b
snd) [(Int64, Tail)]
ls)


-- dummyLoc :: SrcLoc
-- dummyLoc = (SrcLoc (Loc (Pos "" 0 0 0) (Pos "" 0 0 0)))

codegenTriv :: VEnv -> Triv -> C.Exp
codegenTriv :: VEnv -> Triv -> Exp
codegenTriv VEnv
_ (VarTriv Var
v) = Id -> SrcLoc -> Exp
C.Var (Var -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent Var
v SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc
codegenTriv VEnv
_ (IntTriv Int64
i) = [cexp| $int:i |]
codegenTriv VEnv
_ (CharTriv Char
i) = [cexp| $char:i |]
codegenTriv VEnv
_ (FloatTriv Double
i) = [cexp| $double:i |]
codegenTriv VEnv
_ (BoolTriv Bool
b) = case Bool
b of
                               Bool
True -> [cexp| true |]
                               Bool
False -> [cexp| false |]
codegenTriv VEnv
_ (SymTriv Word16
i) = [cexp| $i |]
codegenTriv VEnv
_ (TagTriv Tag
i) = if Tag
i Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
forall a. Num a => a
GL.indirectionAlt
                            then [cexp| GIB_INDIRECTION_TAG |]
                            else if Tag
i Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
forall a. Num a => a
GL.redirectionAlt
                            then [cexp| GIB_REDIRECTION_TAG |]
                            else [cexp| $i |]
codegenTriv VEnv
venv (ProdTriv [Triv]
ls) =
  let ty :: Type
ty = Ty -> Type
codegenTy (Ty -> Type) -> Ty -> Type
forall a b. (a -> b) -> a -> b
$ VEnv -> Triv -> Ty
typeOfTriv VEnv
venv ([Triv] -> Triv
ProdTriv [Triv]
ls)
      args :: [(Maybe Designation, Initializer)]
args = (Triv -> (Maybe Designation, Initializer))
-> [Triv] -> [(Maybe Designation, Initializer)]
forall a b. (a -> b) -> [a] -> [b]
map (\Triv
a -> (Maybe Designation
forall a. Maybe a
Nothing,Exp -> SrcLoc -> Initializer
C.ExpInitializer (VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
a) SrcLoc
forall a. IsLocation a => a
noLoc)) [Triv]
ls
  in [cexp| $(C.CompoundLit ty args noLoc) |]
codegenTriv VEnv
venv (ProjTriv Int
i Triv
trv) =
  let field :: FilePath
field = FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i
  in [cexp| $(codegenTriv venv trv).$id:field |]


-- Type environment
type FEnv = M.Map Var ([Ty], Ty)
type VEnv = M.Map Var Ty
type SyncDeps = [(Var, C.BlockItem)]

writeShadowstack :: Var
writeShadowstack :: Var
writeShadowstack = FilePath -> Var
toVar FilePath
"wstack"

readShadowstack :: Var
readShadowstack :: Var
readShadowstack = FilePath -> Var
toVar FilePath
"rstack"

shadowstackFrame :: Var
shadowstackFrame :: Var
shadowstackFrame = FilePath -> Var
toVar FilePath
"frame"

ssDecls :: [C.BlockItem]
ssDecls :: [BlockItem]
ssDecls =
  [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:stk_ty *$id:readShadowstack = DEFAULT_READ_SHADOWSTACK; |]
  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:stk_ty *$id:writeShadowstack = DEFAULT_WRITE_SHADOWSTACK; |]
  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:frame_ty *$id:shadowstackFrame; |]
  ]
  where
    stk_ty :: Type
stk_ty = [cty|typename GibShadowstack|]
    frame_ty :: Type
frame_ty = [cty|typename GibShadowstackFrame|]

-- | The central codegen function.
codegenTail :: VEnv -> FEnv -> S.Set Var -> Tail -> Ty -> SyncDeps -> PassM [C.BlockItem]

codegenTail :: VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
_ Map Var ([Ty], Ty)
_ Set Var
_ Tail
EndOfMain Ty
_ty SyncDeps
_   = [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
-- Void type:
codegenTail VEnv
_ Map Var ([Ty], Ty)
_ Set Var
_ (RetValsT []) Ty
_ty SyncDeps
_   = [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| return 0; |] ]
-- Single return:
codegenTail VEnv
venv Map Var ([Ty], Ty)
_ Set Var
_ (RetValsT [Triv
tr]) Ty
ty SyncDeps
_ =
    case Ty
ty of
      ProdTy [Ty
_one] -> do
          let arg :: [(Maybe Designation, Initializer)]
arg = [(Maybe Designation
forall a. Maybe a
Nothing,Exp -> SrcLoc -> Initializer
C.ExpInitializer (VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
tr) SrcLoc
forall a. IsLocation a => a
noLoc)]
              ty' :: Type
ty' = Ty -> Type
codegenTy Ty
ty
          [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| return $(C.CompoundLit ty' arg noLoc); |] ]
      Ty
_ -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| return $(codegenTriv venv tr); |] ]
-- Multiple return:
codegenTail VEnv
venv Map Var ([Ty], Ty)
_ Set Var
_ (RetValsT [Triv]
ts) Ty
ty SyncDeps
_ =
    [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| return $(C.CompoundLit ty' args noLoc); |] ]
    where args :: [(Maybe Designation, Initializer)]
args = (Triv -> (Maybe Designation, Initializer))
-> [Triv] -> [(Maybe Designation, Initializer)]
forall a b. (a -> b) -> [a] -> [b]
map (\Triv
a -> (Maybe Designation
forall a. Maybe a
Nothing,Exp -> SrcLoc -> Initializer
C.ExpInitializer (VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
a) SrcLoc
forall a. IsLocation a => a
noLoc)) [Triv]
ts
          ty' :: Type
ty' = Ty -> Type
codegenTy Ty
ty

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (AssnValsT [(Var, Ty, Triv)]
ls Maybe Tail
bod_maybe) Ty
ty SyncDeps
sync_deps = do
    case Maybe Tail
bod_maybe of
      Just Tail
bod -> do
        let venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty)] -> VEnv) -> [(Var, Ty)] -> VEnv
forall a b. (a -> b) -> a -> b
$ ((Var, Ty, Triv) -> (Var, Ty)) -> [(Var, Ty, Triv)] -> [(Var, Ty)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
a,Ty
b,Triv
_) -> (Var
a,Ty
b)) [(Var, Ty, Triv)]
ls)
                    VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv
        [BlockItem]
bod' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
bod Ty
ty SyncDeps
sync_deps
        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
mut (Ty -> Type
codegenTy Ty
ty) Var
vr (VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
triv) | (Var
vr,Ty
ty,Triv
triv) <- [(Var, Ty, Triv)]
ls ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
bod'
      Maybe Tail
Nothing  ->
        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
mut (Ty -> Type
codegenTy Ty
ty) Var
vr (VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
triv) | (Var
vr,Ty
ty,Triv
triv) <- [(Var, Ty, Triv)]
ls ]

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (Switch Var
lbl Triv
tr Alts
alts Maybe Tail
def) Ty
ty SyncDeps
sync_deps =
    case Maybe Tail
def of
      Maybe Tail
Nothing  -> let (Alts
rest,Alts
lastone) = Alts -> (Alts, Alts)
splitAlts Alts
alts in
                  VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Var
-> Triv
-> Alts
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
genSwitch VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Var
lbl Triv
tr Alts
rest (Alts -> Tail
altTail Alts
lastone) Ty
ty SyncDeps
sync_deps
      Just Tail
def -> VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Var
-> Triv
-> Alts
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
genSwitch VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Var
lbl Triv
tr Alts
alts Tail
def Ty
ty SyncDeps
sync_deps

codegenTail VEnv
venv Map Var ([Ty], Ty)
_ Set Var
_ (TailCall Var
v [Triv]
ts) Ty
_ty SyncDeps
_ =
    [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| return $( C.FnCall (cid v) (map (codegenTriv venv) ts) noLoc ); |] ]

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (IfT Triv
e0 Tail
e1 Tail
e2) Ty
ty SyncDeps
sync_deps = do
    [BlockItem]
e1' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
e1 Ty
ty SyncDeps
sync_deps
    [BlockItem]
e2' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
e2 Ty
ty SyncDeps
sync_deps
    [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| if ($(codegenTriv venv e0)) { $items:e1' } else { $items:e2' } |] ]

codegenTail VEnv
_ Map Var ([Ty], Ty)
_ Set Var
_ (ErrT FilePath
s) Ty
_ty SyncDeps
_ = [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| printf("%s\n", $s); |]
                                            , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |] ]


-- We could eliminate these earlier
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetTrivT (Var
vr,Ty
rty,Triv
rhs) Tail
body) Ty
ty SyncDeps
sync_deps =
    do let venv' :: VEnv
venv' = Var -> Ty -> VEnv -> VEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
vr Ty
rty VEnv
venv
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy rty) $id:vr = ($ty:(codegenTy rty)) $(codegenTriv venv rhs); |] ]
                [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal

-- TODO: extend rts with arena primitives, and invoke them here
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetArenaT Var
vr Tail
body) Ty
ty SyncDeps
sync_deps =
    do [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ArenaTy) $id:vr = gib_alloc_arena();|] ]
              [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetAllocT Var
lhs [(Ty, Triv)]
vals Tail
body) Ty
ty SyncDeps
sync_deps =
    do let structTy :: Type
structTy = Ty -> Type
codegenTy ([Ty] -> Ty
ProdTy (((Ty, Triv) -> Ty) -> [(Ty, Triv)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Ty, Triv) -> Ty
forall a b. (a, b) -> a
fst [(Ty, Triv)]
vals))
           size :: Exp
size = [cexp| sizeof($ty:structTy) |]
           venv' :: VEnv
venv' = Var -> Ty -> VEnv -> VEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
lhs Ty
CursorTy VEnv
venv
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
       let alloc :: BlockItem
alloc = if (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CountParRegions DynFlags
dflags) Bool -> Bool -> Bool
|| (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CountAllRegions DynFlags
dflags)
                   then Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
PtrTy) Var
lhs [cexp| gib_alloc_counted_struct( $size ) |]
                   else Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
PtrTy) Var
lhs [cexp| gib_alloc( $size ) |]
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
              (BlockItem
alloc BlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
:
               [ Stm -> BlockItem
C.BlockStm [cstm| (($ty:structTy *)  $id:lhs)->$id:fld = $(codegenTriv venv trv); |]
               | (Int
ix,(Ty
_ty,Triv
trv)) <- [Int] -> [(Ty, Triv)] -> [(Int, (Ty, Triv))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(Ty, Triv)]
vals
               , let fld :: FilePath
fld = FilePath
"field"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
ix] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                 [BlockItem]
tal)

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetAvailT [Var]
vs Tail
body) Ty
ty SyncDeps
sync_deps =
    do let (SyncDeps
avail, SyncDeps
sync_deps') = ((Var, BlockItem) -> Bool) -> SyncDeps -> (SyncDeps, SyncDeps)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\(Var
v,BlockItem
_) -> Var -> [Var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Var
v [Var]
vs) SyncDeps
sync_deps
       [BlockItem]
tl <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps'
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ (((Var, BlockItem) -> BlockItem) -> SyncDeps -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (Var, BlockItem) -> BlockItem
forall a b. (a, b) -> b
snd SyncDeps
avail) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tl

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetUnpackT [(Var, Ty)]
bs Var
scrt Tail
body) Ty
ty SyncDeps
sync_deps =
    do let mkFld :: Int -> C.Id
           mkFld :: Int -> Id
mkFld Int
i = FilePath -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) SrcLoc
forall a. IsLocation a => a
noLoc

           fldTys :: [Ty]
fldTys = ((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
bs
           struct_ty :: Type
struct_ty = Ty -> Type
codegenTy ([Ty] -> Ty
ProdTy [Ty]
fldTys)

           mk_bind :: Int -> (Var, Ty) -> InitGroup
mk_bind Int
i (Var
v, Ty
t) = [cdecl|
             $ty:(codegenTy t) $id:v = ( ( $ty:struct_ty * ) $exp:(cid scrt) )->$id:(mkFld i);
           |]

           binds :: [InitGroup]
binds = (Int -> (Var, Ty) -> InitGroup)
-> [Int] -> [(Var, Ty)] -> [InitGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Var, Ty) -> InitGroup
mk_bind [Int
0..] [(Var, Ty)]
bs
           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bs) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv

       [BlockItem]
body' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((InitGroup -> BlockItem) -> [InitGroup] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map InitGroup -> BlockItem
C.BlockDecl [InitGroup]
binds [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
body')

-- Here we unzip the tuple into assignments to local variables.
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetIfT [(Var, Ty)]
bnds (Triv
e0,Tail
e1,Tail
e2) Tail
body) Ty
ty SyncDeps
sync_deps =

    do let decls :: [BlockItem]
decls = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:vr0; |]
                   | (Var
vr0,Ty
ty0) <- [(Var, Ty)]
bnds ]
       let e1' :: Tail
e1' = Tail -> [(Var, Ty)] -> Tail
rewriteReturns Tail
e1 [(Var, Ty)]
bnds
           e2' :: Tail
e2' = Tail -> [(Var, Ty)] -> Tail
rewriteReturns Tail
e2 [(Var, Ty)]
bnds

           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv

       [BlockItem]
e1'' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
e1' Ty
ty SyncDeps
sync_deps
       [BlockItem]
e2'' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
e2' Ty
ty SyncDeps
sync_deps
       -- Int 1 is Boolean true:
       let ifbod :: [BlockItem]
ifbod = [ Stm -> BlockItem
C.BlockStm [cstm| if ($(codegenTriv venv e0)) { $items:e1'' } else { $items:e2'' } |] ]
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
decls [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
ifbod [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetTimedT Bool
flg [(Var, Ty)]
bnds Tail
rhs Tail
body) Ty
ty SyncDeps
sync_deps =

    do let decls :: [BlockItem]
decls = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:vr0; |]
                   | (Var
vr0,Ty
ty0) <- [(Var, Ty)]
bnds ]
       let rhs' :: Tail
rhs' = Tail -> [(Var, Ty)] -> Tail
rewriteReturns Tail
rhs [(Var, Ty)]
bnds
       [BlockItem]
rhs'' <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
rhs' Ty
ty SyncDeps
sync_deps
       Var
itertime  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"itertime"
       Var
batchtime <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"batchtime"
       Var
selftimed <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"selftimed"
       Var
times <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"times"
       Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
       let ident :: Var
ident = case [(Var, Ty)]
bnds of
                     ((Var
v,Ty
_):[(Var, Ty)]
_) -> Var
v
                     [(Var, Ty)]
_ -> (FilePath -> Var
toVar FilePath
"")
           begn :: FilePath
begn  = FilePath
"begin_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Var -> FilePath
fromVar Var
ident)
           end :: FilePath
end   = FilePath
"end_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Var -> FilePath
fromVar Var
ident)
           iters :: FilePath
iters = FilePath
"iters_"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Var -> FilePath
fromVar Var
ident)
           vec_ty :: Type
vec_ty = Ty -> Type
codegenTy (Ty -> Ty
VectorTy Ty
FloatTy)

           timebod :: [BlockItem]
timebod = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:vec_ty ($id:times) = gib_vector_alloc(gib_get_iters_param(), sizeof(double)); |]
                     , InitGroup -> BlockItem
C.BlockDecl [cdecl| struct timespec $id:begn; |]
                     , InitGroup -> BlockItem
C.BlockDecl [cdecl| struct timespec $id:end; |] ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++

                     (if Bool
flg
                         -- Save and restore EXCEPT on the last iteration.  This "cancels out" the effect of intermediate allocations.
                      then (let body :: [BlockItem]
body = [ Stm -> BlockItem
C.BlockStm [cstm| if ( $id:iters != gib_get_iters_param()-1) {
                                                         gib_list_bumpalloc_save_state();
                                                         gib_ptr_bumpalloc_save_state();
                                                         } |]
                                       , Stm -> BlockItem
C.BlockStm [cstm| clock_gettime(CLOCK_MONOTONIC_RAW, & $id:begn );  |]
                                       ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                                       [BlockItem]
rhs''[BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                                       [ Stm -> BlockItem
C.BlockStm [cstm| clock_gettime(CLOCK_MONOTONIC_RAW, &$(cid (toVar end))); |]
                                       , Stm -> BlockItem
C.BlockStm [cstm| if ( $id:iters != gib_get_iters_param()-1) {
                                                         gib_list_bumpalloc_restore_state();
                                                         gib_ptr_bumpalloc_restore_state();
                                                         } |]
                                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| double $id:itertime = gib_difftimespecs(&$(cid (toVar begn)), &$(cid (toVar end))); |]
                                       , Stm -> BlockItem
C.BlockStm [cstm| printf("itertime: %lf\n", $id:itertime); |]
                                       , Stm -> BlockItem
C.BlockStm [cstm| gib_vector_inplace_update($id:times, $id:iters, &($id:itertime)); |]
                                       ]
                            in [ Stm -> BlockItem
C.BlockStm [cstm| for (long long $id:iters = 0; $id:iters < gib_get_iters_param(); $id:iters ++) { $items:body } |]
                               , Stm -> BlockItem
C.BlockStm [cstm| gib_vector_inplace_sort($id:times, gib_compare_doubles); |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| double *$id:tmp = (double*) gib_vector_nth($id:times, (gib_get_iters_param() / 2)); |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| double $id:selftimed = *($id:tmp); |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| double $id:batchtime = gib_sum_timing_array($id:times); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| gib_print_timing_array($id:times); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| gib_vector_free($id:times); |]
                               ])

                         -- else
                      else [ Stm -> BlockItem
C.BlockStm [cstm| clock_gettime(CLOCK_MONOTONIC_RAW, & $id:begn );  |]
                           , Stm -> BlockItem
C.BlockStm [cstm| { $items:rhs'' } |]
                           , Stm -> BlockItem
C.BlockStm [cstm| clock_gettime(CLOCK_MONOTONIC_RAW, &$(cid (toVar end))); |]
                           , InitGroup -> BlockItem
C.BlockDecl [cdecl| double $id:selftimed = gib_difftimespecs(&$(cid (toVar begn)), &$(cid (toVar end))); |]
                           , Stm -> BlockItem
C.BlockStm [cstm| gib_vector_free($id:times); |]
                           ])
           withPrnt :: [BlockItem]
withPrnt = [BlockItem]
timebod [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                      (if Bool
flg
                       then [ Stm -> BlockItem
C.BlockStm [cstm| printf("ITERS: %ld\n", gib_get_iters_param()); |]
                            , Stm -> BlockItem
C.BlockStm [cstm| printf("SIZE: %ld\n", gib_get_size_param()); |]
                            , Stm -> BlockItem
C.BlockStm [cstm| printf("BATCHTIME: %e\n", $id:batchtime); |]
                            , Stm -> BlockItem
C.BlockStm [cstm| printf("SELFTIMED: %e\n", $id:selftimed); |]
                            ]
                       else [ Stm -> BlockItem
C.BlockStm [cstm| printf("SIZE: %ld\n", gib_get_size_param()); |]
                            , Stm -> BlockItem
C.BlockStm [cstm| printf("SELFTIMED: %e\n", gib_difftimespecs(&$(cid (toVar begn)), &$(cid (toVar end)))); |] ])
       let venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
decls [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
withPrnt [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal


codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetCallT Bool
False [(Var, Ty)]
bnds Var
ratr [Triv]
rnds Tail
body) Ty
ty SyncDeps
sync_deps
    | [] <- [(Var, Ty)]
bnds = do [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                      [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [Exp -> BlockItem
toStmt Exp
fnexp] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
    | [(Var, Ty)
bnd] <- [(Var, Ty)]
bnds =  let fn_ret_ty :: Ty
fn_ret_ty = ([Ty], Ty) -> Ty
forall a b. (a, b) -> b
snd (Map Var ([Ty], Ty)
fenv Map Var ([Ty], Ty) -> Var -> ([Ty], Ty)
forall k a. Ord k => Map k a -> k -> a
M.! Var
ratr)
                           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv in
                       case Ty
fn_ret_ty of
                         -- Copied from the otherwise case below.
                         ProdTy [Ty
_one] -> do
                           Var
nam <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ FilePath -> Var
toVar FilePath
"tmp_struct"
                           let bind :: (Var, Ty) -> FilePath -> BlockItem
bind (Var
v,Ty
t) FilePath
f = Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
t) Var
v (Exp -> Id -> SrcLoc -> Exp
C.Member (Var -> Exp
cid Var
nam) (FilePath -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent FilePath
f SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc)
                               fields :: [FilePath]
fields = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) [Int
0 :: Int .. [(Var, Ty)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Var, Ty)]
bnds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                               ty0 :: Ty
ty0 = [Ty] -> Ty
ProdTy ([Ty] -> Ty) -> [Ty] -> Ty
forall a b. (a -> b) -> a -> b
$ ((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
bnds
                               init :: [BlockItem]
init = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:nam = $(fnexp); |] ]
                           [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
init [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ ((Var, Ty) -> FilePath -> BlockItem)
-> [(Var, Ty)] -> [FilePath] -> [BlockItem]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Var, Ty) -> FilePath -> BlockItem
bind [(Var, Ty)]
bnds [FilePath]
fields [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
                         ProdTy [] -> do
                           -- nam <- gensym "tmp"
                           let init :: [BlockItem]
init = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy fn_ret_ty) $id:(fst bnd) = $(fnexp); |] ]
                           [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
init [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
                         Ty
_ -> do
                           [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                           let call :: BlockItem
call = Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy ((Var, Ty) -> Ty
forall a b. (a, b) -> b
snd (Var, Ty)
bnd)) ((Var, Ty) -> Var
forall a b. (a, b) -> a
fst (Var, Ty)
bnd) (Exp
fnexp)
                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem
call] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
    | Bool
otherwise = do
       Var
nam <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ FilePath -> Var
toVar FilePath
"tmp_struct"
       let bind :: (Var, Ty) -> FilePath -> BlockItem
bind (Var
v,Ty
t) FilePath
f = Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
t) Var
v (Exp -> Id -> SrcLoc -> Exp
C.Member (Var -> Exp
cid Var
nam) (FilePath -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent FilePath
f SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc)
           fields :: [FilePath]
fields = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) [Int
0 :: Int .. [(Var, Ty)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Var, Ty)]
bnds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
           ty0 :: Ty
ty0 = [Ty] -> Ty
ProdTy ([Ty] -> Ty) -> [Ty] -> Ty
forall a b. (a -> b) -> a -> b
$ ((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
bnds
           init :: [BlockItem]
init = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:nam = $(fnexp); |] ]
           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
init [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ ((Var, Ty) -> FilePath -> BlockItem)
-> [(Var, Ty)] -> [FilePath] -> [BlockItem]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Var, Ty) -> FilePath -> BlockItem
bind [(Var, Ty)]
bnds [FilePath]
fields [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
  where
    fncall :: Exp
fncall =
      let rnds' :: [Exp]
rnds' = (Triv -> Exp) -> [Triv] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (VEnv -> Triv -> Exp
codegenTriv VEnv
venv) [Triv]
rnds
          rnds'' :: [Exp]
rnds'' = if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
ratr Set Var
sort_fns
                   then (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Exp
rnd -> [cexp| &$rnd|]) [Exp]
rnds'
                   else [Exp]
rnds'
      in Exp -> [Exp] -> SrcLoc -> Exp
C.FnCall (Var -> Exp
cid Var
ratr) [Exp]
rnds'' SrcLoc
forall a. IsLocation a => a
noLoc
    fnexp :: Exp
fnexp = FilePath -> SrcLoc -> Exp
C.EscExp (Doc -> FilePath
prettyCompact (Doc
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
fncall)) SrcLoc
forall a. IsLocation a => a
noLoc

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetCallT Bool
True [(Var, Ty)]
bnds Var
ratr [Triv]
rnds Tail
body) Ty
ty SyncDeps
sync_deps
    | [] <- [(Var, Ty)]
bnds = do [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                      [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [Exp -> BlockItem
toStmt Exp
spawnexp] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
    | [(Var, Ty)
bnd] <- [(Var, Ty)]
bnds  = let fn_ret_ty :: Ty
fn_ret_ty = ([Ty], Ty) -> Ty
forall a b. (a, b) -> b
snd (Map Var ([Ty], Ty)
fenv Map Var ([Ty], Ty) -> Var -> ([Ty], Ty)
forall k a. Ord k => Map k a -> k -> a
M.! Var
ratr)
                           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv in
                       case Ty
fn_ret_ty of
                         -- Copied from the otherwise case below.
                         ProdTy [Ty
_one] -> do
                           Var
nam <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ FilePath -> Var
toVar FilePath
"tmp_struct"
                           let bind :: (Var, Ty) -> FilePath -> (Var, BlockItem)
bind (Var
v,Ty
t) FilePath
f = (Var
v, Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
t) Var
v (Exp -> Id -> SrcLoc -> Exp
C.Member (Var -> Exp
cid Var
nam) (FilePath -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent FilePath
f SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc))
                               fields :: [FilePath]
fields = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) [Int
0 :: Int .. [(Var, Ty)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Var, Ty)]
bnds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                               ty0 :: Ty
ty0 = [Ty] -> Ty
ProdTy ([Ty] -> Ty) -> [Ty] -> Ty
forall a b. (a -> b) -> a -> b
$ ((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
bnds
                               init :: [BlockItem]
init = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:nam = $(spawnexp); |] ]
                               bind_after_sync :: SyncDeps
bind_after_sync = ((Var, Ty) -> FilePath -> (Var, BlockItem))
-> [(Var, Ty)] -> [FilePath] -> SyncDeps
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Var, Ty) -> FilePath -> (Var, BlockItem)
bind [(Var, Ty)]
bnds [FilePath]
fields
                           [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty (SyncDeps
sync_deps SyncDeps -> SyncDeps -> SyncDeps
forall a. [a] -> [a] -> [a]
++ SyncDeps
bind_after_sync)
                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
init [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
                         ProdTy [Ty]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"codegenTail: LetCallT" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Var -> FilePath
fromVar Var
ratr
                         Ty
_ -> do
                           [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
                           let call :: BlockItem
call = Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy ((Var, Ty) -> Ty
forall a b. (a, b) -> b
snd (Var, Ty)
bnd)) ((Var, Ty) -> Var
forall a b. (a, b) -> a
fst (Var, Ty)
bnd) (Exp
spawnexp)
                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem
call] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tal
    | Bool
otherwise = do
       Var
nam <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ FilePath -> Var
toVar FilePath
"tmp_struct"
       let bind :: (Var, Ty) -> FilePath -> (Var, BlockItem)
bind (Var
v,Ty
t) FilePath
f = (Var
v, Type -> Var -> Exp -> BlockItem
forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn (Ty -> Type
codegenTy Ty
t) Var
v (Exp -> Id -> SrcLoc -> Exp
C.Member (Var -> Exp
cid Var
nam) (FilePath -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent FilePath
f SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc))
           fields :: [FilePath]
fields = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) [Int
0 :: Int .. [(Var, Ty)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Var, Ty)]
bnds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
           ty0 :: Ty
ty0 = [Ty] -> Ty
ProdTy ([Ty] -> Ty) -> [Ty] -> Ty
forall a b. (a -> b) -> a -> b
$ ((Var, Ty) -> Ty) -> [(Var, Ty)] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Ty
forall a b. (a, b) -> b
snd [(Var, Ty)]
bnds
           init :: [BlockItem]
init = [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty0) $id:nam = $(spawnexp); |] ]

       let bind_after_sync :: SyncDeps
bind_after_sync = ((Var, Ty) -> FilePath -> (Var, BlockItem))
-> [(Var, Ty)] -> [FilePath] -> SyncDeps
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Var, Ty) -> FilePath -> (Var, BlockItem)
bind [(Var, Ty)]
bnds [FilePath]
fields
           venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv
       [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty (SyncDeps
sync_deps SyncDeps -> SyncDeps -> SyncDeps
forall a. [a] -> [a] -> [a]
++ SyncDeps
bind_after_sync)
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
init [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++  [BlockItem]
tal
  where
    fncall :: Exp
fncall = Exp -> [Exp] -> SrcLoc -> Exp
C.FnCall (Var -> Exp
cid Var
ratr) ((Triv -> Exp) -> [Triv] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (VEnv -> Triv -> Exp
codegenTriv VEnv
venv) [Triv]
rnds) SrcLoc
forall a. IsLocation a => a
noLoc
    spawnexp :: Exp
spawnexp = FilePath -> SrcLoc -> Exp
C.EscExp (Doc -> FilePath
prettyCompact (FilePath -> Doc
text FilePath
"cilk_spawn" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
fncall)) SrcLoc
forall a. IsLocation a => a
noLoc
    _seqexp :: Exp
_seqexp = FilePath -> SrcLoc -> Exp
C.EscExp (Doc -> FilePath
prettyCompact (Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
fncall)) SrcLoc
forall a. IsLocation a => a
noLoc

codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (LetPrimCallT [(Var, Ty)]
bnds Prim
prm [Triv]
rnds Tail
body) Ty
ty SyncDeps
sync_deps =
    do let venv' :: VEnv
venv' = ([(Var, Ty)] -> VEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty)]
bnds) VEnv -> VEnv -> VEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` VEnv
venv
       [BlockItem]
bod' <- case Prim
prm of
                 Prim
ParSync -> VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty []
                 Prim
_       -> VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv' Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
body Ty
ty SyncDeps
sync_deps
       DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
       let isPacked :: Bool
isPacked = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Packed DynFlags
dflags
           noGC :: Bool
noGC = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DisableGC DynFlags
dflags
           genGC :: Bool
genGC = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenGc DynFlags
dflags

       [BlockItem]
pre <- case Prim
prm of
                 Prim
AddP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) + $(codegenTriv venv pright); |] ]
                 Prim
SubP -> let (Var
outV,Ty
outT) = [(Var, Ty)] -> (Var, Ty)
forall a. HasCallStack => [a] -> a
head [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) - $(codegenTriv venv pright); |] ]
                 Prim
MulP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) * $(codegenTriv venv pright); |]]
                 Prim
DivP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) / $(codegenTriv venv pright); |]]
                 Prim
ModP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) % $(codegenTriv venv pright); |]]
                 Prim
ExpP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                         [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_expll($(codegenTriv venv pleft), $(codegenTriv venv pright)); |]]
                 Prim
RandP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = rand(); |]]
                 Prim
FRandP-> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                              fty :: Type
fty = Ty -> Type
codegenTy Ty
FloatTy in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($ty:fty) rand() / ($ty:fty) (RAND_MAX); |]]
                 Prim
FSqrtP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                               [Triv
arg] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = sqrt($(codegenTriv venv arg)) ; |]]

                 Prim
FTanP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                              [Triv
arg] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = tan($(codegenTriv venv arg)) ; |]]

                 Prim
FloatToIntP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                    [Triv
arg] = [Triv]
rnds
                                    ity :: Type
ity= Ty -> Type
codegenTy Ty
IntTy in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($ty:ity) ($(codegenTriv venv arg)) ; |]]

                 Prim
IntToFloatP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                    [Triv
arg] = [Triv]
rnds
                                    fty :: Type
fty = Ty -> Type
codegenTy Ty
FloatTy in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($ty:fty) ($(codegenTriv venv arg)) ; |]]

                 Prim
EqP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                            [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) == $(codegenTriv venv pright)); |]]
                 Prim
LtP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                            [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) < $(codegenTriv venv pright)); |]]
                 Prim
GtP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                            [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) > $(codegenTriv venv pright)); |]]
                 Prim
LtEqP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                              [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) <= $(codegenTriv venv pright)); |]]
                 Prim
GtEqP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                              [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) >= $(codegenTriv venv pright)); |]]
                 Prim
OrP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                            [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) || $(codegenTriv venv pright)); |]]
                 Prim
AndP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                             [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($(codegenTriv venv pleft) && $(codegenTriv venv pright)); |]]

                 Prim
EqSymP -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                               [Triv
pleft,Triv
pright] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) == $(codegenTriv venv pright); |]]

                 EqBenchProgP FilePath
str -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                     in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = strcmp($str,gib_read_bench_prog_param()) == 0; |]]

                 DictInsertP Ty
_ -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
arena),(VarTriv Var
dict),Triv
keyTriv,Triv
valTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_dict_insert_ptr($id:arena, $id:dict, $(codegenTriv venv keyTriv), $(codegenTriv venv valTriv)); |] ]
                 DictLookupP Ty
_ -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
dict),Triv
keyTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_dict_lookup_ptr($id:dict, $(codegenTriv venv keyTriv)); |] ]
                 DictEmptyP Ty
_ty -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                   in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = 0; |] ]
                 -- DictHasKeyP PtrTy -> let [(outV,IntTy)] = bnds
                 --                          [(VarTriv dict)] = rnds in pure
                 --    [ C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:outV = dict_has_key_ptr($id:dict); |] ]
                 DictHasKeyP Ty
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"codegen: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Prim -> FilePath
forall a. Show a => a -> FilePath
show Prim
prm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"unhandled."

                 Prim
SymSetEmpty -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_empty_set(); |] ]
                 Prim
SymSetInsert -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                     [(VarTriv Var
set),Triv
valTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_insert_set($id:set, $(codegenTriv venv valTriv)); |] ]
                 Prim
SymSetContains -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                       [(VarTriv Var
set),Triv
valTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_contains_set($id:set, $(codegenTriv venv valTriv)); |] ]

                 Prim
SymHashEmpty -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                 in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_empty_hash(); |] ]
                 Prim
SymHashInsert -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
hash),Triv
keyTriv,Triv
valTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_insert_hash($id:hash, $(codegenTriv venv keyTriv), $(codegenTriv venv valTriv)); |] ]
                 Prim
SymHashLookup -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
hash),Triv
keyTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_lookup_hash($id:hash, $(codegenTriv venv keyTriv)); |] ]

                 Prim
SymHashContains -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                        [(VarTriv Var
hash),Triv
keyTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_contains_hash($id:hash, $(codegenTriv venv keyTriv)); |] ]

                 Prim
IntHashEmpty -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                 in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_empty_hash(); |] ]
                 Prim
IntHashInsert -> let [(Var
outV,Ty
outT)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
hash),Triv
keyTriv,Triv
valTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = gib_insert_hash($id:hash, $(codegenTriv venv keyTriv), $(codegenTriv venv valTriv)); |] ]
                 Prim
IntHashLookup -> let [(Var
outV,Ty
ty)] = [(Var, Ty)]
bnds
                                      [(VarTriv Var
hash),Triv
keyTriv] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_lookup_hash($id:hash, $(codegenTriv venv keyTriv)); |] ]

                 NewBuffer Multiplicity
mul -> do
                   DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
                   let countRegions :: Bool
countRegions = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CountAllRegions DynFlags
dflags
                   let [(Var
reg, Ty
CursorTy),(Var
outV,Ty
CursorTy),(Var
endV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                       bufsize :: Exp
bufsize = Multiplicity -> Exp
codegenMultiplicity Multiplicity
mul
                   if Bool
countRegions
                   then
                     [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                       [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy)* $id:reg = gib_alloc_counted_region($exp:bufsize); |]
                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = $id:reg->start; |]
                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:endV = $id:reg->end; |]
                       ]
                   else
                     [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                       (if Bool
genGC
                        then [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:reg = gib_alloc_region($exp:bufsize); |] ]
                        else [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:reg = gib_alloc_region_on_heap($exp:bufsize); |] ]) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = $id:reg.start; |]
                          , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:endV = $id:reg.end; |]
                          ]


                 NewParBuffer Multiplicity
mul -> do
                   DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
                   let countRegions :: Bool
countRegions = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CountParRegions DynFlags
dflags
                   let [(Var
reg, Ty
CursorTy),(Var
outV,Ty
CursorTy),(Var
endV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                       bufsize :: Exp
bufsize = Multiplicity -> Exp
codegenMultiplicity Multiplicity
mul
                   if Bool
countRegions
                   then
                     [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                       [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy)* $id:reg = gib_alloc_counted_region($exp:bufsize); |]
                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = $id:reg->start; |]
                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:endV = $id:reg->end; |]
                       ]
                   else
                     [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                       (if Bool
genGC
                        then [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:reg = gib_alloc_region($exp:bufsize); |] ]
                        else [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:reg = gib_alloc_region_on_heap($exp:bufsize); |] ]) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                          [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = $id:reg.start; |]
                          , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:endV = $id:reg.end; |]
                          ]
                 ScopedBuffer Multiplicity
mul -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                         bufsize :: Exp
bufsize = Multiplicity -> Exp
codegenMultiplicity Multiplicity
mul
                                     in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                             [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ( $ty:(codegenTy CursorTy) ) gib_scoped_alloc($exp:bufsize); |] ]

                 ScopedParBuffer Multiplicity
mul -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                            bufsize :: Exp
bufsize = Multiplicity -> Exp
codegenMultiplicity Multiplicity
mul
                                        in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                             [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ( $ty:(codegenTy CursorTy) ) gib_scoped_alloc($exp:bufsize); |] ]

                 -- generated during newbuffer.
                 EndOfBuffer{} -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

                 Prim
FreeBuffer -> if Bool
noGC Bool -> Bool -> Bool
|| Bool
genGC
                               then [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                               else
                                 let [(VarTriv Var
_reg),(VarTriv Var
_rcur),(VarTriv Var
endr_cur)] = [Triv]
rnds
                                 in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                 [ Stm -> BlockItem
C.BlockStm [cstm| gib_free_region($id:endr_cur); |] ]

                 Prim
WriteTag -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                 [t :: Triv
t@(TagTriv{}),(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                             [ Stm -> BlockItem
C.BlockStm [cstm| *($ty:(codegenTy TagTyPacked) *) ($id:cur) = $(codegenTriv venv t); |]
                             , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = $id:cur + 1; |] ]
                 Prim
ReadTag -> let [(Var
tagV,Ty
TagTyPacked),(Var
curV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                [(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy TagTyPacked) $id:tagV = *($ty:(codegenTy TagTyPacked) *) ($id:cur); |]
                            , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:curV = $id:cur + 1; |] ]

                 WriteScalar Scalar
s -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                      [Triv
val,(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                  [ Stm -> BlockItem
C.BlockStm [cstm| *( $ty:(codegenTy (scalarToTy s))  *)($id:cur) = $(codegenTriv venv val); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ($id:cur) + sizeof( $ty:(codegenTy (scalarToTy s)) ); |] ]

                 ReadScalar Scalar
s -> let [(Var
valV,Ty
valTy),(Var
curV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                     [(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                     [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy valTy) $id:valV = *( $ty:(codegenTy valTy) *)($id:cur); |]
                                     , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:curV = ($id:cur) + sizeof( $ty:(codegenTy (scalarToTy s))); |] ]

                 Prim
TagCursor  -> let [(Var
taggedV,Ty
_)] = [(Var, Ty)]
bnds
                                   [(VarTriv Var
a), (VarTriv Var
b)] = [Triv]
rnds
                                   tag_t :: Type
tag_t = [cty| typename uint16_t |]
                                   tagged_ptr_t :: Type
tagged_ptr_t = [cty| typename uintptr_t |]
                               in do Var
offset <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"offset"
                                     [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                       [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tag_t $id:offset = $id:b - $id:a; |]
                                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tagged_ptr_t $id:taggedV = GIB_STORE_TAG($id:a, $id:offset); |]
                                       ]

                 Prim
ReadTaggedCursor -> do
                               Var
tagged <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tagged_tmpcur"
                               let [(Var
next,Ty
CursorTy),(Var
afternext,Ty
CursorTy),(Var
tag,Ty
IntTy)] = [(Var, Ty)]
bnds
                                   [(VarTriv Var
cur)] = [Triv]
rnds
                                   tagged_t :: Type
tagged_t = [cty| typename uintptr_t |]
                                   tag_t :: Type
tag_t = [cty| typename uint16_t |]
                               [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                 [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tagged_t $id:tagged = *($ty:tagged_t *) ($id:cur); |]
                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:next = GIB_UNTAG($id:tagged); |]
                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:afternext = ($id:cur) + 8; |]
                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tag_t $id:tag = GIB_GET_TAG($id:tagged); |]
                                 ]

                 Prim
WriteTaggedCursor ->
                                let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                    [Triv
val,(VarTriv Var
cur)] = [Triv]
rnds
                                    tagged_t :: Type
tagged_t = [cty| typename uintptr_t |] in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                 [ Stm -> BlockItem
C.BlockStm [cstm| *( $ty:tagged_t  *)($id:cur) = ($ty:tagged_t) $(codegenTriv venv val); |]
                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ($id:cur) + 8; |] ]

                 Prim
ReadCursor -> let [(Var
next,Ty
CursorTy),(Var
afternext,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                   [(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                               [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:next = *($ty:(codegenTy CursorTy) *) ($id:cur); |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:afternext = ($id:cur) + 8; |]
                               ]

                 Prim
WriteCursor -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                    [Triv
val,(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                 [ Stm -> BlockItem
C.BlockStm [cstm| *( $ty:(codegenTy CursorTy)  *)($id:cur) = $(codegenTriv venv val); |]
                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ($id:cur) + 8; |] ]

                 Prim
WriteList    -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                     [Triv
val,(VarTriv Var
cur)] = [Triv]
rnds
                                     ls_ty :: Ty
ls_ty = Ty -> Ty
ListTy ([Ty] -> Ty
ProdTy []) in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                  [ Stm -> BlockItem
C.BlockStm [cstm| *( $ty:(codegenTy ls_ty)  *)($id:cur) = $(codegenTriv venv val); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ($id:cur) + sizeof( $ty:(codegenTy ls_ty) ); |] ]

                 Prim
ReadList     -> let [(Var
valV,Ty
valTy),(Var
curV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                     [(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                     [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy valTy) $id:valV = *( $ty:(codegenTy valTy) *)($id:cur); |]
                                     , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:curV = ($id:cur) + sizeof( $ty:(codegenTy valTy)); |] ]


                 Prim
WriteVector    -> let [(Var
outV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                       [Triv
val,(VarTriv Var
cur)] = [Triv]
rnds
                                       ls_ty :: Ty
ls_ty = Ty -> Ty
VectorTy ([Ty] -> Ty
ProdTy []) in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                  [ Stm -> BlockItem
C.BlockStm [cstm| *( $ty:(codegenTy ls_ty)  *)($id:cur) = $(codegenTriv venv val); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ($id:cur) + sizeof( $ty:(codegenTy ls_ty) ); |] ]

                 Prim
ReadVector     -> let [(Var
valV,Ty
valTy),(Var
curV,Ty
CursorTy)] = [(Var, Ty)]
bnds
                                       [(VarTriv Var
cur)] = [Triv]
rnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                       [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy valTy) $id:valV = *( $ty:(codegenTy valTy) *)($id:cur); |]
                                       , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:curV = ($id:cur) + sizeof( $ty:(codegenTy valTy)); |] ]

                 IndirectionBarrier FilePath
tycon ->
                   let [(VarTriv Var
from_loc), (VarTriv Var
end_from_reg),
                        (VarTriv Var
to_loc), (VarTriv Var
end_to_reg)] = [Triv]
rnds
                       tycon_t :: Id
tycon_t = (FilePath -> SrcLoc -> Id
C.Id (FilePath
tycon FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T") SrcLoc
forall a. IsLocation a => a
noLoc)
                   in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| gib_indirection_barrier($id:from_loc, $id:end_from_reg, $id:to_loc, $id:end_to_reg, $id:tycon_t); |] ]

                 Prim
BoundsCheck -> do
                   Var
_new_chunk   <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"new_chunk"
                   Var
_chunk_start <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"chunk_start"
                   Var
_chunk_end   <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"chunk_end"
                   let [(IntTriv Int64
i),(VarTriv Var
bound), (VarTriv Var
cur)] = [Triv]
rnds
                       {-
                       bck = [ C.BlockDecl [cdecl| $ty:(codegenTy ChunkTy) $id:new_chunk = gib_grow_region($id:bound); |]
                             , C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:chunk_start = $id:new_chunk.start; |]
                             , C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:chunk_end = $id:new_chunk.end; |]
                             , C.BlockStm  [cstm|  $id:bound = $id:chunk_end; |]
                             , C.BlockStm  [cstm|  *($ty:(codegenTy TagTyPacked) *) ($id:cur) = GIB_REDIRECTION_TAG; |]
                             , C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) redir =  $id:cur + 1; |]
                             , C.BlockStm  [cstm|  *($ty:(codegenTy CursorTy) *) redir = $id:chunk_start; |]
                             , C.BlockStm  [cstm|  $id:cur = $id:chunk_start; |]
                             ]
                   return [ C.BlockStm [cstm| if (($id:cur + $int:i) > $id:bound) { $items:bck }  |] ]
                        -}
                       bck :: [BlockItem]
bck = [ Stm -> BlockItem
C.BlockStm  [cstm|  gib_grow_region(& $id:cur, & $id:bound); |] ]
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| if (($id:cur + $int:i) > $id:bound) { $items:bck }  |] ]

                 Prim
SizeOfPacked -> let [(Var
sizeV,Ty
IntTy)] = [(Var, Ty)]
bnds
                                     [(VarTriv Var
startV), (VarTriv Var
endV)] = [Triv]
rnds
                                 in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                   [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:sizeV = ($ty:(codegenTy IntTy)) $id:endV - $id:startV; |] ]
                 Prim
SizeOfScalar -> let [(Var
sizeV,Ty
IntTy)] = [(Var, Ty)]
bnds
                                     [(VarTriv Var
w)]   = [Triv]
rnds
                                 in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                   [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:sizeV = ($ty:(codegenTy IntTy)) sizeof($id:w); |] ]


                 Prim
GetFirstWord ->
                  let [Triv
ptr] = [Triv]
rnds in
                  case [(Var, Ty)]
bnds of
                    [(Var
outV,Ty
outTy)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                     [ InitGroup -> BlockItem
C.BlockDecl [cdecl|
                            $ty:(codegenTy outTy) $id:outV =
                              * (( $ty:(codegenTy outTy) *) $(codegenTriv venv ptr));
                          |] ]
                    [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from GetFirstWord: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 Prim
SizeParam -> let [(Var
outV,Ty
IntTy)] = [(Var, Ty)]
bnds in [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:outV = gib_get_size_param(); |] ]

                 Prim
PrintInt ->
                     let [Triv
arg] = [Triv]
rnds in
                     case [(Var, Ty)]
bnds of
                       [(Var
outV,Ty
ty)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = printf("%ld", $(codegenTriv venv arg)); |] ]
                       [] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| printf("%ld", $(codegenTriv venv arg)); |] ]
                       [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from PrintInt: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 Prim
PrintChar ->
                     let [Triv
arg] = [Triv]
rnds in
                     case [(Var, Ty)]
bnds of
                       [(Var
outV,Ty
ty)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = printf("%c", $(codegenTriv venv arg)); |] ]
                       [] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| printf("%c", $(codegenTriv venv arg)); |] ]
                       [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from PrintInt: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 Prim
PrintFloat ->
                     let [Triv
arg] = [Triv]
rnds in
                     case [(Var, Ty)]
bnds of
                       [(Var
outV,Ty
ty)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = printf("%.2f", $(codegenTriv venv arg)); |] ]
                       [] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| printf("%.2f", $(codegenTriv venv arg)); |] ]
                       [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from PrintInt: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 Prim
PrintBool ->
                     let [Triv
arg] = [Triv]
rnds in
                     case [(Var, Ty)]
bnds of
                       [(Var
outV,Ty
ty)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = printf("%d", $(codegenTriv venv arg)); |] ]
                       [] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| printf("%d", $(codegenTriv venv arg)); |] ]
                       [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from PrintInt: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 Prim
PrintSym ->
                     let [Triv
arg] = [Triv]
rnds in
                     case [(Var, Ty)]
bnds of
                       [(Var
outV,Ty
ty)] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:outV = gib_print_symbol($(codegenTriv venv arg)); |] ]
                       [] -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| gib_print_symbol($(codegenTriv venv arg)); |] ]
                       [(Var, Ty)]
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of return bindings from PrintSym: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 PrintString FilePath
str
                     | [] <- [(Var, Ty)]
bnds, [] <- [Triv]
rnds -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| printf( $string:str ); |] ]
                     | Bool
otherwise -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error(FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"wrong number of args/return values expected from PrintString prim: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++([Triv], [(Var, Ty)]) -> FilePath
forall a. Show a => a -> FilePath
show ([Triv]
rnds,[(Var, Ty)]
bnds)

                 WritePackedFile FilePath
fp FilePath
tyc
                    | [Triv
inV] <- [Triv]
rnds -> do
                        -- Inputs to the copy function.
                        Var
outreg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"outreg"
                        Var
start_outreg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"start_outreg"
                        Var
end_outreg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"end_outreg"
                        Var
end_inreg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"end_inreg"
                        -- Output from the copy function.
                        Var
end_outreg2 <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"end_outreg2"
                        Var
end_inreg2 <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"end_inreg2"
                        Var
copy_start <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"copy_start"
                        Var
copy_end <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"copy_end"
                        Var
copy_size <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"copy_size"
                        let rnds2 :: [Triv]
rnds2 = [Var -> Triv
VarTriv Var
end_inreg, Var -> Triv
VarTriv Var
end_outreg, Var -> Triv
VarTriv Var
start_outreg, Triv
inV]
                            bnds2 :: [(Var, Ty)]
bnds2 = [(Var
end_outreg2,Ty
CursorTy),(Var
end_inreg2,Ty
CursorTy),(Var
copy_start,Ty
CursorTy),(Var
copy_end,Ty
CursorTy)]
                        [BlockItem]
call_copyfn <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns (Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
LetCallT Bool
False [(Var, Ty)]
bnds2 (FilePath -> Var
GL.mkCopySansPtrsFunName FilePath
tyc) [Triv]
rnds2 ([(Var, Ty, Triv)] -> Maybe Tail -> Tail
AssnValsT [] Maybe Tail
forall a. Maybe a
Nothing)) ([Ty] -> Ty
ProdTy []) SyncDeps
sync_deps
                        let tyfile :: Type
tyfile = [cty| typename FILE |]
                            tysize :: Type
tysize = [cty| typename size_t |]
                        Var
out_hdl <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"out_hdl"
                        Var
wrote <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"wrote"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                           (if Bool
genGC
                            then [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:outreg = gib_alloc_region_on_heap(gib_get_biginf_init_chunk_size()); |] ]
                            else [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy RegionTy) $id:outreg = gib_alloc_region_on_heap(gib_get_biginf_init_chunk_size()); |] ]) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                               [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:start_outreg = $id:outreg.start; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:end_outreg = $id:outreg.end; |]
                                 -- This would ideally be the *end* of the input region corresponding to inV
                                 -- but we have don't have at hand here. Passing in NULL is okay because this pointer
                                 -- is unused in the copy function.
                                 -- To get the actual end of the input region, we'll have to encode WritePackedFile as an
                                 -- expression (instead of a PrimAppE), and add the appropriate code in ThreadRegions.hs.
                                 -- Sticking with the hacky and less invasive approach for now.
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:end_inreg = NULL; |]
                               ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
call_copyfn [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                               [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tyfile *$id:out_hdl = fopen($string:fp, "wb"); |]
                               -- , _todo
                               -- , _todo
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tysize $id:copy_size = ($ty:(codegenTy IntTy)) ($id:copy_end - $id:copy_start); |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:tysize $id:wrote = fwrite($id:copy_start, $id:copy_size, 1, $id:out_hdl); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| fclose($id:out_hdl); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| printf("Wrote: %s\n", $string:fp); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| gib_free_region($id:end_outreg); |]
                               , Stm -> BlockItem
C.BlockStm [cstm| free($id:outreg); |]
                               ]
                    | Bool
otherwise -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"WritePackedFile, wrong arguments "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Triv] -> FilePath
forall a. Show a => a -> FilePath
show [Triv]
rndsFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
", or expected bindings "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 -- FINISHME: Codegen here depends on whether we are in --packed mode or not.
                 ReadPackedFile Maybe FilePath
mfile FilePath
tyc
                     | [] <- [Triv]
rnds, [(Var
outV,Ty
_outT)] <- [(Var, Ty)]
bnds -> do
                             let filename :: Exp
filename = case Maybe FilePath
mfile of
                                              Just FilePath
f  -> [cexp| $string:f |] -- Fixed at compile time.
                                              Maybe FilePath
Nothing -> [cexp| gib_read_benchfile_param() |] -- Will be set by command line arg.
                                 unpackName :: Var
unpackName = FilePath -> Var
GL.mkUnpackerName FilePath
tyc
                                 unpackcall :: Tail
unpackcall = Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
LetCallT Bool
False [(Var
outV,Ty
PtrTy),(FilePath -> Var
toVar FilePath
"junk",Ty
CursorTy)]
                                                    Var
unpackName [Var -> Triv
VarTriv (FilePath -> Var
toVar FilePath
"ptr")] ([(Var, Ty, Triv)] -> Maybe Tail -> Tail
AssnValsT [] Maybe Tail
forall a. Maybe a
Nothing)

                                 mmap_size :: Var
mmap_size = Var -> Var -> Var
varAppend Var
outV Var
"_size"

                                 mmapCode :: [BlockItem]
mmapCode =
                                  [ InitGroup -> BlockItem
C.BlockDecl[cdecl| int fd = open( $filename, O_RDONLY); |]
                                  , Stm -> BlockItem
C.BlockStm[cstm| { if(fd == -1) { fprintf(stderr,"fopen failed\n"); abort(); }} |]
                                  , InitGroup -> BlockItem
C.BlockDecl[cdecl| struct stat st; |]
                                  , Stm -> BlockItem
C.BlockStm  [cstm| fstat(fd, &st); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:mmap_size = st.st_size;|]
                                  , InitGroup -> BlockItem
C.BlockDecl[cdecl| $ty:(codegenTy CursorTy) ptr = ($ty:(codegenTy CursorTy)) mmap(0,st.st_size,PROT_READ,MAP_PRIVATE,fd,0); |]
                                  , Stm -> BlockItem
C.BlockStm[cstm| { if(ptr==MAP_FAILED) { fprintf(stderr,"mmap failed\n"); abort(); }} |]
                                  ]
                             [BlockItem]
docall <- if Bool
isPacked
                                       -- In packed mode we eagerly FORCE the IO to happen before we start benchmarking:
                                       then [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Stm -> BlockItem
C.BlockStm [cstm| { int sum=0; for(int i=0; i < st.st_size; i++) sum += ptr[i]; } |]
                                                 , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CursorTy) $id:outV = ptr; |]]
                                       else VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
unpackcall Ty
voidTy SyncDeps
sync_deps
                             [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
mmapCode [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
docall
                     | Bool
otherwise -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"ReadPackedFile, wrong arguments "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Triv] -> FilePath
forall a. Show a => a -> FilePath
show [Triv]
rndsFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
", or expected bindings "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 ReadArrayFile Maybe (FilePath, Int)
mfile Ty
ty
                   | [] <- [Triv]
rnds, [(Var
outV,Ty
_outT)] <- [(Var, Ty)]
bnds -> do
                           let parse_in_c :: Ty -> FilePath
parse_in_c Ty
t = case Ty
t of
                                                Ty
IntTy   -> FilePath
"%ld"
                                                Ty
FloatTy -> FilePath
"%f"
                                                Ty
CharTy  -> FilePath
"%c"
                                                Ty
_ -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"ReadArrayFile: Lists of type " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ty -> FilePath
forall a. Out a => a -> FilePath
sdoc Ty
ty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not allowed."

                           Var
elem <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"arr_elem"
                           Var
fp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"fp"
                           Var
line <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"line"
                           Var
len <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"len"
                           Var
read <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"read"
                           Var
line_num <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"i"

                           ([Var]
tmps, [FilePath]
tmps_parsers, [BlockItem]
tmps_assns, [BlockItem]
tmps_decls) <-
                                 case Ty
ty of
                                     Ty
IntTy -> do
                                       Var
one <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                                       let assn :: BlockItem
assn = Stm -> BlockItem
C.BlockStm [cstm| $id:elem = $id:one ; |]
                                       ([Var], [FilePath], [BlockItem], [BlockItem])
-> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Var
one], [Ty -> FilePath
parse_in_c Ty
ty], [ BlockItem
assn ], [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:one; |] ])
                                     Ty
FloatTy -> do
                                       Var
one <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                                       let assn :: BlockItem
assn = Stm -> BlockItem
C.BlockStm [cstm| $id:elem = $id:one ; |]
                                       ([Var], [FilePath], [BlockItem], [BlockItem])
-> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Var
one], [Ty -> FilePath
parse_in_c Ty
ty], [ BlockItem
assn ], [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy FloatTy) $id:one; |] ])
                                     Ty
CharTy -> do
                                       Var
one <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                                       let assn :: BlockItem
assn = Stm -> BlockItem
C.BlockStm [cstm| $id:elem = $id:one ; |]
                                       ([Var], [FilePath], [BlockItem], [BlockItem])
-> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Var
one], [Ty -> FilePath
parse_in_c Ty
ty], [ BlockItem
assn ], [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CharTy) $id:one; |] ])
                                     ProdTy [Ty]
tys -> do
                                       [Var]
vs <- (Ty -> PassM Var) -> [Ty] -> PassM [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) -> [a] -> m [b]
mapM (\Ty
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp") [Ty]
tys
                                       let decls :: [BlockItem]
decls = ((Var, Ty) -> BlockItem) -> [(Var, Ty)] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
name, Ty
t) -> InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy t) $id:name; |] ) ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [Ty]
tys)
                                           parsers :: [FilePath]
parsers = (Ty -> FilePath) -> [Ty] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Ty -> FilePath
parse_in_c [Ty]
tys
                                           assns :: [BlockItem]
assns = ((Var, Integer) -> BlockItem) -> [(Var, Integer)] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v, Integer
i) ->
                                                           let field :: FilePath
field = FilePath
"field" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
i)
                                                           in Stm -> BlockItem
C.BlockStm [cstm| $id:elem.$id:field = $id:v; |])
                                                   ([Var] -> [Integer] -> [(Var, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [Integer
0..])
                                       ([Var], [FilePath], [BlockItem], [BlockItem])
-> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Var]
vs, [FilePath]
parsers, [BlockItem]
assns, [BlockItem]
decls)
                                     Ty
_ -> FilePath -> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM ([Var], [FilePath], [BlockItem], [BlockItem]))
-> FilePath -> PassM ([Var], [FilePath], [BlockItem], [BlockItem])
forall a b. (a -> b) -> a -> b
$ FilePath
"ReadArrayFile: Lists of type " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ty -> FilePath
forall a. Out a => a -> FilePath
sdoc Ty
ty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not allowed."

                           let scanf_vars :: [Exp]
scanf_vars   = (Var -> Exp) -> [Var] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
v -> [cexp| &($id:v) |]) [Var]
tmps
                               scanf_line :: Exp
scanf_line = [cexp| $id:line |]
                               scanf_format :: Exp
scanf_format = [cexp| $string:(L.intercalate " " tmps_parsers) |]
                               scanf_rator :: Exp
scanf_rator  = Id -> SrcLoc -> Exp
C.Var (FilePath -> SrcLoc -> Id
C.Id FilePath
"sscanf" SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc
                               scanf :: Exp
scanf = Exp -> [Exp] -> SrcLoc -> Exp
C.FnCall Exp
scanf_rator (Exp
scanf_line Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: Exp
scanf_format Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
scanf_vars) SrcLoc
forall a. IsLocation a => a
noLoc

                           let (Exp
filename, Exp
filelength) = case Maybe (FilePath, Int)
mfile of
                                            Just (FilePath
f, Int
i)  -> ( [cexp| $string:f |]
                                                            , [cexp| $int:i |]) -- Fixed at compile time.
                                            Maybe (FilePath, Int)
Nothing -> ( [cexp| gib_read_arrayfile_param() |]
                                                       , [cexp| gib_read_arrayfile_length_param() |]) -- Will be set by command line arg.

                           [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                                  [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy ty)) ($id:outV) = gib_vector_alloc($filelength, sizeof($ty:(codegenTy ty))); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy ty) $id:elem; |]
                                  , Stm -> BlockItem
C.BlockStm  [cstm| FILE *($id:fp); |]
                                  , InitGroup -> BlockItem
C.BlockDecl [cdecl| char *($id:line) = NULL; |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| size_t ($id:len); |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| $id:len = 0; |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| ssize_t ($id:read); |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| $id:fp = fopen( $filename, "r"); |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| { if($id:fp == NULL) { fprintf(stderr,"fopen failed\n"); abort(); }} |]
                                  ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
tmps_decls [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                                  [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:line_num = 0; |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| while(($id:read = getline(&($id:line), &($id:len), $id:fp)) != -1) {
                                                      int xxxx = $scanf;
                                                      $items:tmps_assns
                                                      gib_vector_inplace_update($id:outV, $id:line_num, &($id:elem));
                                                      $id:line_num++;
                                                    } |]
                                  ]

                   | Bool
otherwise -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"ReadPackedFile, wrong arguments "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Triv] -> FilePath
forall a. Show a => a -> FilePath
show [Triv]
rndsFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
", or expected bindings "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[(Var, Ty)] -> FilePath
forall a. Show a => a -> FilePath
show [(Var, Ty)]
bnds

                 MMapFileSize Var
v -> do
                       let [(Var
outV,Ty
IntTy)] = [(Var, Ty)]
bnds
                           -- Must match with mmap_size set by ReadPackedFile
                           mmap_size :: Var
mmap_size = Var -> Var -> Var
varAppend Var
v Var
"_size"
                       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl[cdecl| $ty:(codegenTy IntTy) $id:outV = $id:mmap_size; |] ]

                 Prim
ParSync -> do
                    let e :: Exp
e = [cexp| cilk_sync |]
                    [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| $exp:e; |] ] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ (((Var, BlockItem) -> BlockItem) -> SyncDeps -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (Var, BlockItem) -> BlockItem
forall a b. (a, b) -> b
snd SyncDeps
sync_deps)

                 Prim
GetCilkWorkerNum -> do
                   let [(Var
outV, Ty
IntTy)] = [(Var, Ty)]
bnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ InitGroup -> BlockItem
C.BlockDecl [cdecl| int $id:outV = __cilkrts_get_worker_number(); |] ]

                 Prim
IsBig -> do
                   let [(Var
outV, Ty
BoolTy)] = [(Var, Ty)]
bnds
                       -- [i,arg] = rnds
                       -- e = [cexp| gib_is_big($(codegenTriv venv i), $(codegenTriv venv arg)) |]
                       e :: Exp
e = [cexp| false |]
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy BoolTy) $id:outV = $exp:e; |] ]

                 Prim
Gensym  -> do
                   let [(Var
outV,Ty
SymTy)] = [(Var, Ty)]
bnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy SymTy) $id:outV = gib_gensym(); |] ]

                 Prim
FreeSymTable -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Stm -> BlockItem
C.BlockStm [cstm| gib_free_symtable(); |]]

                 VAllocP Ty
elty -> do
                   let ty1 :: Type
ty1 = Ty -> Type
codegenTy (Ty -> Ty
VectorTy Ty
elty)
                       [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [Triv
i] = [Triv]
rnds
                       i' :: Exp
i' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
i
                   Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:tmp = sizeof( $ty:(codegenTy elty)); |]
                          , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:ty1 $id:outV = gib_vector_alloc($exp:i', $id:tmp); |]
                          ]

                 VFreeP Ty
_elty -> do
                   let [Triv
vec] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| gib_vector_free($(codegenTriv venv vec)); |] ]

                 VFree2P Ty
_elty -> do
                   let [Triv
vec] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| free($(codegenTriv venv vec)); |] ]

                 VNthP Ty
elty -> do
                   let ty1 :: Type
ty1 = Ty -> Type
codegenTy Ty
elty
                       [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [VarTriv Var
ls, Triv
i] = [Triv]
rnds
                       i' :: Exp
i' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
i
                   Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:ty1 *($id:tmp); |]
                          , Stm -> BlockItem
C.BlockStm  [cstm| $id:tmp = ($ty:ty1 *) gib_vector_nth($id:ls,$exp:i'); |]
                          , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:ty1 $id:outV = *($id:tmp); |]
                          ]

                 VLengthP{} -> do
                   let [(Var
v,Ty
IntTy)] = [(Var, Ty)]
bnds
                       [VarTriv Var
ls] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:v = gib_vector_length($id:ls); |] ]

                 InplaceVUpdateP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [VarTriv Var
old_ls, Triv
i, Triv
x] = [Triv]
rnds
                       i' :: Exp
i' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
i
                       xexp :: Exp
xexp = [cexp| $exp:(codegenTriv venv x) |]
                   case Triv
x of
                     VarTriv{} ->
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_update($id:old_ls, $exp:i', &$exp:xexp); |] ]
                     ProdTriv{} ->
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_update($id:old_ls, $exp:i', &$exp:xexp); |] ]
                     IntTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_update($id:old_ls, $exp:i', &$id:tmp); |] ]
                     CharTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy CharTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_update($id:old_ls, $exp:i', &$id:tmp); |] ]
                     FloatTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy FloatTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_update($id:old_ls, $exp:i', &$id:tmp); |] ]
                     Triv
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"codegen: InplaceVUpdateP: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Triv -> FilePath
forall a. Out a => a -> FilePath
sdoc Triv
x

                 VConcatP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [Triv
ls] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_concat($exp:(codegenTriv venv ls)); |]
                          ]

                 VSortP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [VarTriv Var
old_ls, VarTriv Var
sort_fn] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_sort($id:old_ls, $id:sort_fn); |] ]

                 InplaceVSortP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [VarTriv Var
old_ls, VarTriv Var
sort_fn] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_inplace_sort($id:old_ls, $id:sort_fn); |] ]

                 VSliceP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [Triv
from, Triv
to, VarTriv Var
old_ls] = [Triv]
rnds
                       from' :: Exp
from' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
from
                       to' :: Exp
to' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
to
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_slice($exp:from', $exp:to', $id:old_ls); |] ]

                 VMergeP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [VarTriv Var
ls1, VarTriv Var
ls2] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (VectorTy elty)) $id:outV = gib_vector_merge($id:ls1, $id:ls2); |] ]

                 PDictAllocP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                                  [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictAllocP todo\n"); |]
                                  , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                  ]

                 PDictInsertP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                   [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictInsertP todo\n"); |]
                                   , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                   ]

                 PDictLookupP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                   [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictLookupP todo\n"); |]
                                   , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                   ]

                 PDictHasKeyP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                   [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictHasKeyP todo\n"); |]
                                   , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                   ]

                 PDictForkP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                 [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictForkP todo\n"); |]
                                 , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                 ]

                 PDictJoinP Ty
_k Ty
_v -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                 [ Stm -> BlockItem
C.BlockStm [cstm| printf("PDictJoinP todo\n"); |]
                                 , Stm -> BlockItem
C.BlockStm [cstm| exit(1); |]
                                 ]

                 LLAllocP Ty
elty -> do
                   let ty1 :: Type
ty1 = Ty -> Type
codegenTy (Ty -> Ty
ListTy Ty
elty)
                       [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:ty1 $id:outV = gib_list_alloc(sizeof( $ty:(codegenTy elty))); |] ]

                 LLIsEmptyP Ty
_elty -> do
                   let [(Var
outV,Ty
outTy)] = [(Var, Ty)]
bnds
                       [Triv
ls] = [Triv]
rnds
                       ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                       outTy' :: Type
outTy' = Ty -> Type
codegenTy Ty
outTy
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:outTy' $id:outV = gib_list_is_empty($exp:ls'); |] ]

                 LLConsP Ty
elty -> do
                   let [(Var
outV,Ty
_)] = [(Var, Ty)]
bnds
                       [Triv
x, VarTriv Var
old_ls] = [Triv]
rnds
                       xexp :: Exp
xexp = [cexp| $exp:(codegenTriv venv x) |]
                   case Triv
x of
                     VarTriv{} ->
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (ListTy elty)) $id:outV = gib_list_cons(&$exp:xexp, $id:old_ls); |] ]
                     ProdTriv{} ->
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (ListTy elty)) $id:outV = gib_list_cons(&$exp:xexp, $id:old_ls); |] ]
                     IntTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (ListTy elty)) $id:outV = gib_list_cons(&$id:tmp, $id:old_ls); |] ]
                     FloatTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy FloatTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (ListTy elty)) $id:outV = gib_list_cons(&$id:tmp, $id:old_ls); |] ]
                     SymTriv{} -> do
                        Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                        [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy IntTy) $id:tmp = $exp:xexp; |]
                               , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy (ListTy elty)) $id:outV = gib_list_cons(&$id:tmp, $id:old_ls); |] ]
                     Triv
_ -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error (FilePath -> PassM [BlockItem]) -> FilePath -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ FilePath
"codegen: LLConsP: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Triv -> FilePath
forall a. Out a => a -> FilePath
sdoc Triv
x

                 LLHeadP Ty
_elty -> do
                   let [(Var
outV,Ty
outTy)] = [(Var, Ty)]
bnds
                       [Triv
ls] = [Triv]
rnds
                       ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                       outTy' :: Type
outTy' = Ty -> Type
codegenTy Ty
outTy
                   Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tmp"
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:outTy' *($id:tmp); |]
                          , Stm -> BlockItem
C.BlockStm  [cstm| $id:tmp = ($ty:outTy' *) gib_list_head($exp:ls'); |]
                          , InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:outTy' $id:outV = *($id:tmp); |] ]

                 LLTailP Ty
_elty -> do
                  let [(Var
outV,Ty
outTy)] = [(Var, Ty)]
bnds
                      [Triv
ls] = [Triv]
rnds
                      ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                      outTy' :: Type
outTy' = Ty -> Type
codegenTy Ty
outTy
                  [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:outTy' $id:outV = gib_list_tail($exp:ls'); |] ]

                 LLFreeP Ty
_elty -> do
                  let [Triv
ls] = [Triv]
rnds
                      ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                  [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| gib_list_free($exp:ls'); |] ]

                 LLFree2P Ty
_elty -> do
                  let [Triv
ls] = [Triv]
rnds
                      ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                  [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| free($exp:ls'); |] ]

                 LLCopyP Ty
_elty -> do
                  let [(Var
outV,Ty
outTy)] = [(Var, Ty)]
bnds
                      [Triv
ls] = [Triv]
rnds
                      ls' :: Exp
ls' = VEnv -> Triv -> Exp
codegenTriv VEnv
venv Triv
ls
                      outTy' :: Type
outTy' = Ty -> Type
codegenTy Ty
outTy
                  [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:outTy' $id:outV = gib_list_copy($exp:ls'); |] ]


                 Prim
GetNumProcessors -> do
                   let [(Var
outV,Ty
outTy)] = [(Var, Ty)]
bnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:(codegenTy outTy) $id:outV = gib_get_num_processors(); |] ]

                 Prim
PrintRegionCount -> [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| gib_print_global_region_count(); |] ]

                 SSPush SSModality
stk FilePath
tycon -> do
                   let tycon_t :: Id
tycon_t = (FilePath -> SrcLoc -> Id
C.Id (FilePath
tycon FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_T") SrcLoc
forall a. IsLocation a => a
noLoc)
                       [VarTriv Var
loc, VarTriv Var
endloc] = [Triv]
rnds
                   case SSModality
stk of
                     SSModality
Write ->
                       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| gib_shadowstack_push($id:writeShadowstack, $id:loc, $id:endloc, Stk, $id:tycon_t); |] ]
                     SSModality
Read ->
                       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| gib_shadowstack_push($id:readShadowstack, $id:loc, $id:endloc, Stk, $id:tycon_t); |] ]

                 SSPop SSModality
stk -> do
                   let [VarTriv Var
loc, VarTriv Var
endloc] = [Triv]
rnds
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$
                     (case SSModality
stk of
                        SSModality
Write -> [ Stm -> BlockItem
C.BlockStm [cstm| $id:shadowstackFrame = gib_shadowstack_pop($id:writeShadowstack); |] ]
                        SSModality
Read -> [ Stm -> BlockItem
C.BlockStm [cstm| $id:shadowstackFrame = gib_shadowstack_pop($id:readShadowstack); |] ]) [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
                     [ Stm -> BlockItem
C.BlockStm [cstm| $id:loc = $id:shadowstackFrame->ptr; |]
                     , Stm -> BlockItem
C.BlockStm [cstm| $id:endloc = $id:shadowstackFrame->endptr; |]]

                 Prim
Assert -> do
                   let [VarTriv Var
_chk] = [Triv]
rnds
                       ifdef :: FilePath
ifdef = FilePath
"#ifdef _GIBBON_DEBUG"
                       endif :: FilePath
endif = FilePath
"#endif"
                   [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| $escstm:ifdef |]
                          -- , C.BlockStm [cstm| assert($id:chk); |]
                          , Stm -> BlockItem
C.BlockStm [cstm| $escstm:endif |]
                          ]

                 BumpArenaRefCount{} -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error FilePath
"codegen: BumpArenaRefCount not handled."
                 ReadInt{} -> FilePath -> PassM [BlockItem]
forall a. HasCallStack => FilePath -> a
error FilePath
"codegen: ReadInt not handled."

       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
pre [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
bod'

codegenTail VEnv
_ Map Var ([Ty], Ty)
_ Set Var
_ (Goto Var
lbl) Ty
_ty SyncDeps
_ = do
  [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Stm -> BlockItem
C.BlockStm [cstm| goto $id:lbl; |] ]

-- | The sizes for all mulitplicities are defined as globals in the RTS.
-- Note: Must be consistent with the names in RTS!
codegenMultiplicity :: Multiplicity -> C.Exp
codegenMultiplicity :: Multiplicity -> Exp
codegenMultiplicity Multiplicity
mul =
  case Multiplicity
mul of
    Multiplicity
BigInfinite -> [cexp| gib_get_biginf_init_chunk_size() |]
    Multiplicity
Infinite    -> [cexp| gib_get_inf_init_chunk_size() |]
    Bounded Int
i   ->
      let rounded :: Int
rounded = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
18
      in [cexp| $int:rounded |]

-- | Round up a number to a power of 2.
--
-- Copied from https://stackoverflow.com/a/466256.
roundUp :: Int -> Int
roundUp :: Int -> Int
roundUp Int
n = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double
2 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double
forall a. Floating a => a -> a
log (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
log Double
2)))

splitAlts :: Alts -> (Alts, Alts)
splitAlts :: Alts -> (Alts, Alts)
splitAlts (TagAlts [(Tag, Tail)]
ls) = ([(Tag, Tail)] -> Alts
TagAlts ([(Tag, Tail)] -> [(Tag, Tail)]
forall a. HasCallStack => [a] -> [a]
L.init [(Tag, Tail)]
ls), [(Tag, Tail)] -> Alts
TagAlts [[(Tag, Tail)] -> (Tag, Tail)
forall a. HasCallStack => [a] -> a
last [(Tag, Tail)]
ls])
splitAlts (IntAlts [(Int64, Tail)]
ls) = ([(Int64, Tail)] -> Alts
IntAlts ([(Int64, Tail)] -> [(Int64, Tail)]
forall a. HasCallStack => [a] -> [a]
L.init [(Int64, Tail)]
ls), [(Int64, Tail)] -> Alts
IntAlts [[(Int64, Tail)] -> (Int64, Tail)
forall a. HasCallStack => [a] -> a
last [(Int64, Tail)]
ls])

-- | Take a "singleton" Alts and extract the Tail.
altTail :: Alts -> Tail
altTail :: Alts -> Tail
altTail (TagAlts [(Tag
_,Tail
t)]) = Tail
t
altTail (IntAlts [(Int64
_,Tail
t)]) = Tail
t
altTail Alts
oth = FilePath -> Tail
forall a. HasCallStack => FilePath -> a
error (FilePath -> Tail) -> FilePath -> Tail
forall a b. (a -> b) -> a -> b
$ FilePath
"altTail expected a 'singleton' Alts, got: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> Alts -> FilePath
forall a. Out a => Int -> a -> FilePath
abbrv Int
80 Alts
oth


-- Helper for lhs of a case
mk_tag_lhs :: (Integral a, Show a) => a -> C.Exp
mk_tag_lhs :: forall a. (Integral a, Show a) => a -> Exp
mk_tag_lhs a
lhs
    | a
forall a. Num a => a
GL.indirectionAlt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
lhs = Id -> SrcLoc -> Exp
C.Var (FilePath -> SrcLoc -> Id
C.Id FilePath
"GIB_INDIRECTION_TAG" SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc
    | a
forall a. Num a => a
GL.redirectionAlt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
lhs = Id -> SrcLoc -> Exp
C.Var (FilePath -> SrcLoc -> Id
C.Id FilePath
"GIB_REDIRECTION_TAG" SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc
    | Bool
otherwise = Const -> SrcLoc -> Exp
C.Const (FilePath -> Signed -> Integer -> SrcLoc -> Const
C.IntConst (a -> FilePath
forall a. Show a => a -> FilePath
show a
lhs) Signed
C.Unsigned (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
lhs) SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc

mk_int_lhs :: (Integral a, Show a) => a -> C.Exp
mk_int_lhs :: forall a. (Integral a, Show a) => a -> Exp
mk_int_lhs a
lhs = Const -> SrcLoc -> Exp
C.Const (FilePath -> Signed -> Integer -> SrcLoc -> Const
C.IntConst (a -> FilePath
forall a. Show a => a -> FilePath
show a
lhs) Signed
C.Signed   (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
lhs) SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc

normalizeAlts :: Alts -> [(C.Exp, Tail)]
normalizeAlts :: Alts -> [(Exp, Tail)]
normalizeAlts Alts
alts =
    case Alts
alts of
      TagAlts [(Tag, Tail)]
as -> ((Tag, Tail) -> (Exp, Tail)) -> [(Tag, Tail)] -> [(Exp, Tail)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tag -> Exp) -> (Tag, Tail) -> (Exp, Tail)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Tag -> Exp
forall a. (Integral a, Show a) => a -> Exp
mk_tag_lhs) [(Tag, Tail)]
as
      IntAlts [(Int64, Tail)]
as -> ((Int64, Tail) -> (Exp, Tail)) -> [(Int64, Tail)] -> [(Exp, Tail)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int64 -> Exp) -> (Int64, Tail) -> (Exp, Tail)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int64 -> Exp
forall a. (Integral a, Show a) => a -> Exp
mk_int_lhs) [(Int64, Tail)]
as

-- | Generate a proper switch expression instead.
genSwitch :: VEnv -> FEnv -> S.Set Var -> Label -> Triv -> Alts -> Tail -> Ty -> SyncDeps -> PassM [C.BlockItem]
genSwitch :: VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Var
-> Triv
-> Alts
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
genSwitch VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Var
lbl Triv
tr Alts
alts Tail
lastE Ty
ty SyncDeps
sync_deps =
    do let go :: [(C.Exp,Tail)] -> PassM [C.Stm]
           go :: [(Exp, Tail)] -> PassM [Stm]
go [] = do [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
lastE Ty
ty SyncDeps
sync_deps
                      [Stm] -> PassM [Stm]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [[cstm| default: $stm:(mkBlock tal) |]]
           go ((Exp
ex,Tail
tl):[(Exp, Tail)]
rst) =
               do [BlockItem]
tal <- VEnv
-> Map Var ([Ty], Ty)
-> Set Var
-> Tail
-> Ty
-> SyncDeps
-> PassM [BlockItem]
codegenTail VEnv
venv Map Var ([Ty], Ty)
fenv Set Var
sort_fns Tail
tl Ty
ty SyncDeps
sync_deps
                  let tal2 :: [BlockItem]
tal2 = [BlockItem]
tal [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [ Stm -> BlockItem
C.BlockStm [cstm| break; |] ]
                  let this :: Stm
this = [cstm| case $exp:ex : $stm:(mkBlock tal2) |]
                  [Stm]
rst' <- [(Exp, Tail)] -> PassM [Stm]
go [(Exp, Tail)]
rst
                  [Stm] -> PassM [Stm]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stm
thisStm -> [Stm] -> [Stm]
forall a. a -> [a] -> [a]
:[Stm]
rst')
       [Stm]
alts' <- [(Exp, Tail)] -> PassM [Stm]
go (Alts -> [(Exp, Tail)]
normalizeAlts Alts
alts)
       let body :: Stm
body = [BlockItem] -> Stm
mkBlock [ Stm -> BlockItem
C.BlockStm Stm
a | Stm
a <- [Stm]
alts' ]
       [BlockItem] -> PassM [BlockItem]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> PassM [BlockItem])
-> [BlockItem] -> PassM [BlockItem]
forall a b. (a -> b) -> a -> b
$ [ Stm -> BlockItem
C.BlockStm [cstm| $id:lbl: ; |]
                , Stm -> BlockItem
C.BlockStm [cstm| switch ( $exp:(codegenTriv venv tr) ) $stm:body |]]

-- | The identifier after typename refers to typedefs defined in rts.c
--
codegenTy :: Ty -> C.Type
codegenTy :: Ty -> Type
codegenTy Ty
IntTy = [cty|typename GibInt|]
codegenTy Ty
CharTy = [cty|typename GibChar|]
codegenTy Ty
FloatTy= [cty|typename GibFloat|]
codegenTy Ty
BoolTy = [cty|typename GibBool|]
codegenTy Ty
TagTyPacked = [cty|typename GibPackedTag|]
codegenTy Ty
TagTyBoxed  = [cty|typename GibBoxedTag|]
codegenTy Ty
SymTy = [cty|typename GibSym|]
codegenTy Ty
PtrTy = [cty|typename GibPtr|] -- char* - Hack, this could be void* if we have enough casts. [2016.11.06]
codegenTy Ty
CursorTy = [cty|typename GibCursor|]
codegenTy Ty
RegionTy = [cty|typename GibChunk|]
codegenTy Ty
ChunkTy = [cty|typename GibChunk|]
codegenTy (ProdTy []) = [cty|unsigned char|]
codegenTy (ProdTy [Ty]
ts) = DeclSpec -> Decl -> SrcLoc -> Type
C.Type ([Storage] -> [TypeQual] -> TypeSpec -> SrcLoc -> DeclSpec
C.DeclSpec [] [] (Id -> [Id] -> SrcLoc -> TypeSpec
C.Tnamed (FilePath -> SrcLoc -> Id
C.Id FilePath
nam SrcLoc
forall a. IsLocation a => a
noLoc) [] SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc) (SrcLoc -> Decl
C.DeclRoot SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc
    where nam :: FilePath
nam = [Ty] -> FilePath
makeName [Ty]
ts
codegenTy (SymDictTy Var
_ Ty
_t) = [cty|typename GibSymDict|]
codegenTy Ty
SymSetTy = [cty|typename GibSymSet*|]
codegenTy Ty
SymHashTy = [cty|typename GibSymHash*|]
codegenTy Ty
IntHashTy = [cty|typename GibIntHash*|]
codegenTy Ty
ArenaTy = [cty|typename GibArena*|]
codegenTy VectorTy{} = [cty|typename GibVector* |]
codegenTy ListTy{} = [cty|typename GibList* |]
codegenTy PDictTy{} = [cty|typename GibPDict* |]

makeName :: [Ty] -> String
makeName :: [Ty] -> FilePath
makeName [Ty]
tys = (Ty -> FilePath) -> [Ty] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty -> FilePath
makeName' [Ty]
tys FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Prod"

makeName' :: Ty -> String
makeName' :: Ty -> FilePath
makeName' Ty
IntTy       = FilePath
"GibInt"
makeName' Ty
CharTy      = FilePath
"GibChar"
makeName' Ty
FloatTy     = FilePath
"GibFloat"
makeName' Ty
SymTy       = FilePath
"GibSym"
makeName' Ty
BoolTy      = FilePath
"GibBool"
makeName' Ty
CursorTy    = FilePath
"GibCursor"
makeName' Ty
TagTyPacked = FilePath
"GibPackedTag"
makeName' Ty
TagTyBoxed  = FilePath
"GibBoxedTag"
makeName' Ty
PtrTy       = FilePath
"GibPtr"
makeName' (SymDictTy Var
_ Ty
_ty) = FilePath
"GibSymDict"
makeName' Ty
RegionTy = FilePath
"GibChunk"
makeName' Ty
ChunkTy  = FilePath
"GibChunk"
makeName' Ty
ArenaTy  = FilePath
"GibArena"
makeName' VectorTy{} = FilePath
"GibVector"
makeName' ListTy{} = FilePath
"GibList"
makeName' PDictTy{} = FilePath
"PDict"
makeName' (ProdTy [Ty]
tys) = FilePath
"Prod" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Ty -> FilePath) -> [Ty] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty -> FilePath
makeName' [Ty]
tys
makeName' Ty
SymSetTy = FilePath
"GibSymSet"
makeName' Ty
SymHashTy = FilePath
"GibSymHash"
makeName' Ty
IntHashTy = FilePath
"GibIntHash"


makeIcdName :: Ty -> (String, String)
makeIcdName :: Ty -> (FilePath, FilePath)
makeIcdName Ty
ty =
  let ty_name :: FilePath
ty_name  =
        case Ty
ty of
          Ty
IntTy      -> FilePath
"IntTy"
          Ty
FloatTy    -> FilePath
"FloatTy"
          Ty
BoolTy     -> FilePath
"BoolTy"
          Ty
SymTy      -> FilePath
"SymTy"
          ProdTy [Ty]
tys -> [Ty] -> FilePath
makeName [Ty]
tys
          Ty
_ -> FilePath
"codegenTail: Lists of type " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ty -> FilePath
forall a. Out a => a -> FilePath
sdoc Ty
ty FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not allowed."
      icd_name :: FilePath
icd_name = FilePath
ty_name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_icd"
  in (FilePath
ty_name, FilePath
icd_name)


mkBlock :: [C.BlockItem] -> C.Stm
mkBlock :: [BlockItem] -> Stm
mkBlock [BlockItem]
ss = [BlockItem] -> SrcLoc -> Stm
C.Block [BlockItem]
ss SrcLoc
forall a. IsLocation a => a
noLoc

cid :: Var -> C.Exp
cid :: Var -> Exp
cid Var
v = Id -> SrcLoc -> Exp
C.Var (Var -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent Var
v SrcLoc
forall a. IsLocation a => a
noLoc) SrcLoc
forall a. IsLocation a => a
noLoc

toStmt :: C.Exp -> C.BlockItem
toStmt :: Exp -> BlockItem
toStmt Exp
x = Stm -> BlockItem
C.BlockStm [cstm| $exp:x; |]

-- | Create a NEW lexical binding.
assn :: (C.ToIdent v, C.ToExp e) => C.Type -> v -> e -> C.BlockItem
assn :: forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
assn Type
t v
x e
y = InitGroup -> BlockItem
C.BlockDecl [cdecl| $ty:t $id:x = $exp:y; |]

-- | Mutate an existing binding:
mut :: (C.ToIdent v, C.ToExp e) => C.Type -> v -> e -> C.BlockItem
mut :: forall v e. (ToIdent v, ToExp e) => Type -> v -> e -> BlockItem
mut Type
_t v
x e
y = Stm -> BlockItem
C.BlockStm [cstm| $id:x = $exp:y; |]