{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

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

-- | Lowering L3 to the target language.
module Gibbon.Passes.Lower
  ( lower, getTagOfDataCon
  ) where

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

import           Control.Monad
import           Data.Foldable
import           Data.Maybe
import qualified Data.List as L hiding (tail)
import qualified Data.Map as M
import qualified Data.Set as S
import           Data.Int (Int64)
import           Data.Word (Word16)
import           Data.Tuple (swap)
import           Prelude hiding (tail)
import           Text.PrettyPrint.GenericPretty
import qualified Data.List as L

import           Gibbon.Common
import           Gibbon.DynFlags
import           Gibbon.L3.Syntax
import qualified Gibbon.L3.Syntax as L3
import qualified Gibbon.L4.Syntax as T

-- Generating unpack functions from Packed->Pointer representation:
-------------------------------------------------------------------------------

genDcons :: [Ty3] -> Var -> [(T.Ty, T.Triv)] -> PassM T.Tail
genDcons :: [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons (Ty3
x:[Ty3]
xs) Var
tail [(Ty, Triv)]
fields = case Ty3
x of
  PackedTy [Char]
tyCons ()
_ -> do
    Var
ptr  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym  Var
"ptr"
    Var
t    <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym  Var
"tail"
    Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
T.LetCallT Bool
False [(Var
ptr, Ty
T.PtrTy), (Var
t, Ty
T.CursorTy)] ([Char] -> Var
mkUnpackerName [Char]
tyCons) [(Var -> Triv
T.VarTriv Var
tail)]
      (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
xs Var
t ([(Ty, Triv)]
fields [(Ty, Triv)] -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. [a] -> [a] -> [a]
++ [(Ty
T.CursorTy, Var -> Triv
T.VarTriv Var
ptr)])

  -- Int, Float, Sym or Bool
  Ty3
_ | Ty3 -> Bool
forall a. UrTy a -> Bool
isScalarTy Ty3
x ->  do
    Var
val  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"val"
    Var
t    <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tail"
    let l4_ty :: Ty
l4_ty = Ty3 -> Ty
T.fromL3Ty Ty3
x
    [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
val, Ty
l4_ty), (Var
t, Ty
T.CursorTy)] (Scalar -> Prim
T.ReadScalar (Ty3 -> Scalar
forall a. Out a => UrTy a -> Scalar
mkScalar Ty3
x)) [(Var -> Triv
T.VarTriv Var
tail)]
      (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
xs Var
t ([(Ty, Triv)]
fields [(Ty, Triv)] -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. [a] -> [a] -> [a]
++ [(Ty
l4_ty, Var -> Triv
T.VarTriv Var
val)])

  VectorTy Ty3
el_ty -> do
    Var
val <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"val"
    Var
t   <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tail"
    let l4_ty :: Ty
l4_ty = Ty3 -> Ty
T.fromL3Ty Ty3
el_ty
    [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
val, Ty -> Ty
T.VectorTy Ty
l4_ty), (Var
t, Ty
T.CursorTy)] Prim
T.ReadVector [(Var -> Triv
T.VarTriv Var
tail)]
      (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
xs Var
t ([(Ty, Triv)]
fields [(Ty, Triv)] -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. [a] -> [a] -> [a]
++ [(Ty -> Ty
T.VectorTy Ty
l4_ty, Var -> Triv
T.VarTriv Var
val)])

  ListTy Ty3
el_ty -> do
    Var
val <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"val"
    Var
t   <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tail"
    let l4_ty :: Ty
l4_ty = Ty3 -> Ty
T.fromL3Ty Ty3
el_ty
    [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
val, Ty -> Ty
T.ListTy Ty
l4_ty), (Var
t, Ty
T.CursorTy)] Prim
T.ReadList [(Var -> Triv
T.VarTriv Var
tail)]
      (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
xs Var
t ([(Ty, Triv)]
fields [(Ty, Triv)] -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. [a] -> [a] -> [a]
++ [(Ty -> Ty
T.ListTy Ty
l4_ty, Var -> Triv
T.VarTriv Var
val)])

  -- Indirection or redirection pointer
  Ty3
CursorTy -> do
    Var
next <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"next"
    Var
afternext <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"afternext"
    let l4_ty :: Ty
l4_ty = Ty3 -> Ty
T.fromL3Ty Ty3
x
    [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
next, Ty
T.CursorTy),(Var
afternext,Ty
T.CursorTy)] Prim
T.ReadCursor [(Var -> Triv
T.VarTriv Var
tail)] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
xs Var
afternext ([(Ty, Triv)]
fields [(Ty, Triv)] -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. [a] -> [a] -> [a]
++ [(Ty
l4_ty, Var -> Triv
T.VarTriv Var
next)])

  Ty3
_ -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"genDcons: FIXME " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty3 -> [Char]
forall a. Show a => a -> [Char]
show Ty3
x

genDcons [] Var
tail [(Ty, Triv)]
fields     = do
  Var
ptr <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"ptr"
  Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ Var -> [(Ty, Triv)] -> Tail -> Tail
T.LetAllocT Var
ptr [(Ty, Triv)]
fields (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ [Triv] -> Tail
T.RetValsT [Var -> Triv
T.VarTriv Var
ptr, Var -> Triv
T.VarTriv Var
tail]

genAlts :: [(DataCon,[(IsBoxed,Ty3)])] -> Var -> Var -> Int64 -> PassM T.Alts
genAlts :: [([Char], [(Bool, Ty3)])] -> Var -> Var -> Int64 -> PassM Alts
genAlts (([Char]
_dcons, [(Bool, Ty3)]
typs):[([Char], [(Bool, Ty3)])]
xs) Var
tail Var
tag Int64
n = do
  let ([Bool]
_,[Ty3]
typs') = [(Bool, Ty3)] -> ([Bool], [Ty3])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, Ty3)]
typs
  -- WARNING: IsBoxed ignored here
  Tail
curTail <- [Ty3] -> Var -> [(Ty, Triv)] -> PassM Tail
genDcons [Ty3]
typs' Var
tail [(Ty
T.TagTyPacked, Var -> Triv
T.VarTriv Var
tag)]
  Alts
alts    <- [([Char], [(Bool, Ty3)])] -> Var -> Var -> Int64 -> PassM Alts
genAlts [([Char], [(Bool, Ty3)])]
xs Var
tail Var
tag (Int64
nInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1)
  let alt :: Int64
alt = Int64
n
  case Alts
alts of
    T.IntAlts []   -> Alts -> PassM Alts
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alts -> PassM Alts) -> Alts -> PassM Alts
forall a b. (a -> b) -> a -> b
$ [(Int64, Tail)] -> Alts
T.IntAlts [(Int64
alt::Int64, Tail
curTail)]
    -- T.TagAlts []   -> return $ T.TagAlts [(n::Word8, curTail)]
    T.IntAlts [(Int64, Tail)]
tags -> Alts -> PassM Alts
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alts -> PassM Alts) -> Alts -> PassM Alts
forall a b. (a -> b) -> a -> b
$ [(Int64, Tail)] -> Alts
T.IntAlts ((Int64
alt::Int64, Tail
curTail) (Int64, Tail) -> [(Int64, Tail)] -> [(Int64, Tail)]
forall a. a -> [a] -> [a]
: [(Int64, Tail)]
tags)
    -- T.TagAlts tags -> return $ T.TagAlts ((n::Word8, curTail) : tags)
    Alts
_              -> [Char] -> PassM Alts
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Alts) -> [Char] -> PassM Alts
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid case statement type."

genAlts [] Var
_ Var
_ Int64
_                  = Alts -> PassM Alts
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alts -> PassM Alts) -> Alts -> PassM Alts
forall a b. (a -> b) -> a -> b
$ [(Int64, Tail)] -> Alts
T.IntAlts []

genUnpacker :: DDef Ty3 -> PassM T.FunDecl
genUnpacker :: DDef Ty3 -> PassM FunDecl
genUnpacker DDef{Var
tyName :: Var
tyName :: forall a. DDef a -> Var
tyName, [([Char], [(Bool, Ty3)])]
dataCons :: [([Char], [(Bool, Ty3)])]
dataCons :: forall a. DDef a -> [([Char], [(Bool, a)])]
dataCons} = do
  Var
p    <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"p"
  Var
tag  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tag"
  Var
tail <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"tail"
  Alts
alts <- [([Char], [(Bool, Ty3)])] -> Var -> Var -> Int64 -> PassM Alts
genAlts [([Char], [(Bool, Ty3)])]
dataCons Var
tail Var
tag Int64
0
  Var
lbl  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"switch"
  let def_alt :: Tail
def_alt = [Char] -> Tail
T.ErrT ([Char] -> Tail) -> [Char] -> Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown tag in: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
lbl
  Tail
bod  <- Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
tag, Ty
T.TagTyPacked), (Var
tail, Ty
T.CursorTy)] Prim
T.ReadTag [(Var -> Triv
T.VarTriv Var
p)] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
                   Var -> Triv -> Alts -> Maybe Tail -> Tail
T.Switch Var
lbl (Var -> Triv
T.VarTriv Var
tag) Alts
alts (Tail -> Maybe Tail
forall a. a -> Maybe a
Just Tail
def_alt)
  FunDecl -> PassM FunDecl
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return T.FunDecl{ funName :: Var
T.funName  = [Char] -> Var
mkUnpackerName (Var -> [Char]
fromVar Var
tyName),
                    funArgs :: [(Var, Ty)]
T.funArgs  = [(Var
p, Ty
T.CursorTy)],
                    funRetTy :: Ty
T.funRetTy = [Ty] -> Ty
T.ProdTy [Ty
T.PtrTy, Ty
T.CursorTy],
                    funBody :: Tail
T.funBody  = Tail
bod,
                    isPure :: Bool
T.isPure   = Bool
False
                  }


-- | Modify a Tail to *print* its return value and then

-- Utility functions
printString :: String -> (T.Tail -> T.Tail)
printString :: [Char] -> Tail -> Tail
printString [Char]
s = [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.PrintString [Char]
s) []

openParen :: String -> (T.Tail -> T.Tail)
openParen :: [Char] -> Tail -> Tail
openParen [Char]
s = [Char] -> Tail -> Tail
printString ([Char] -> Tail -> Tail) -> [Char] -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" "

closeParen :: T.Tail -> T.Tail
closeParen :: Tail -> Tail
closeParen   = [Char] -> Tail -> Tail
printString [Char]
")"

printSpace :: T.Tail -> T.Tail
printSpace :: Tail -> Tail
printSpace = [Char] -> Tail -> Tail
printString [Char]
" "

sandwich :: (T.Tail -> T.Tail) -> String -> T.Tail -> T.Tail
sandwich :: (Tail -> Tail) -> [Char] -> Tail -> Tail
sandwich Tail -> Tail
mid [Char]
s Tail
end = [Char] -> Tail -> Tail
openParen [Char]
s (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail -> Tail
mid (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail -> Tail
closeParen Tail
end

-- -- Generate printing functions
-- genDconsPrinter :: [Ty3] -> Var -> PassM T.Tail
-- genDconsPrinter (x:xs) tail =
--   case x of
--     L3.PackedTy tyCons _ -> do
--       dflags <- getDynFlags
--       if gopt Opt_Packed dflags
--       then do
--         t    <- gensym "tail"
--         T.LetCallT False [(t, T.CursorTy)] (mkPrinterName tyCons) [(T.VarTriv tail)] <$>
--            maybeSpace <$> genDconsPrinter xs t
--       else do
--         val  <- gensym "val"
--         t    <- gensym "tail"
--         tmp  <- gensym "temp"
--         valc <- gensym "valcur"
--         T.LetPrimCallT [(val, T.IntTy), (t, T.CursorTy)] (T.ReadScalar IntS) [(T.VarTriv tail)] <$>
--           T.LetTrivT (valc, T.CursorTy, T.VarTriv val) <$>
--           T.LetCallT False [(tmp, T.CursorTy)] (mkPrinterName tyCons) [(T.VarTriv valc)] <$>
--             maybeSpace <$> genDconsPrinter xs t

--     L3.CursorTy -> do
--       dflags <- getDynFlags
--       if gopt Opt_Packed dflags
--       then do
--         tail2 <- gensym "tail"
--         T.LetPrimCallT [(tail2, T.CursorTy)] T.AddP [T.VarTriv tail, T.IntTriv 8] <$>
--           genDconsPrinter xs tail2
--       else genDconsPrinter xs tail

--     _ | isScalarTy x ->  do
--       val  <- gensym "val"
--       t    <- gensym "tail"
--       let l4_ty = T.fromL3Ty x
--       T.LetPrimCallT [(val, l4_ty), (t, T.CursorTy)] (T.ReadScalar (mkScalar x)) [(T.VarTriv tail)] <$>
--         printTy False x [T.VarTriv val] <$>
--          maybeSpace <$>
--           genDconsPrinter xs t

--     VectorTy el_ty ->  do
--       val  <- gensym "val"
--       t    <- gensym "tail"
--       let l4_ty = T.fromL3Ty el_ty
--       T.LetPrimCallT [(val, T.VectorTy l4_ty), (t, T.CursorTy)] T.ReadVector [(T.VarTriv tail)] <$>
--         printTy False x [T.VarTriv val] <$>
--          maybeSpace <$>
--           genDconsPrinter xs t

--     ListTy el_ty ->  do
--       val  <- gensym "val"
--       t    <- gensym "tail"
--       let l4_ty = T.fromL3Ty el_ty
--       T.LetPrimCallT [(val, T.ListTy l4_ty), (t, T.CursorTy)] T.ReadList [(T.VarTriv tail)] <$>
--         printTy False x [T.VarTriv val] <$>
--          maybeSpace <$>
--           genDconsPrinter xs t

--     _ -> error "FINISHME: genDconsPrinter"

--  where
--   maybeSpace = if L.null xs
--                then id
--                else printSpace

-- genDconsPrinter [] tail = do
--   return $ closeParen $ T.RetValsT [(T.VarTriv tail)]

-- genAltPrinter :: [(DataCon,[(IsBoxed, Ty3)])] -> Var -> Int64 -> PassM T.Alts
-- -- Don' do anything for indirections. Let 'followRedirects' take care of it.
-- genAltPrinter ((dcons, _):rst) tail n | isIndirectionTag dcons = genAltPrinter rst tail n
-- genAltPrinter ((dcons, typs):xs) tail n = do
--   let (_,typs') = unzip typs
--   -- WARNING: IsBoxed ignored here
--   curTail <- (openParen dcons) <$> genDconsPrinter typs' tail
--   alts    <- genAltPrinter xs tail (n+1)
--   let alt = n
--   case alts of
--     T.IntAlts []   -> return $ T.IntAlts [(alt::Int64, curTail)]
--     -- T.TagAlts []   -> return $ T.TagAlts [(n::Word8, curTail)]
--     T.IntAlts tags -> return $ T.IntAlts ((alt::Int64, curTail) : tags)
--     -- T.TagAlts tags -> return $ T.TagAlts ((n::Word8, curTail) : tags)
--     _              -> error $ "Invalid case statement type."
-- genAltPrinter [] _ _                = return $ T.IntAlts []

-- genPrinter  :: DDef Ty3 -> PassM T.FunDecl
-- genPrinter DDef{tyName, dataCons} = do
--   p    <- gensym "p"
--   tag  <- gensym "tag"
--   tail <- gensym "tail"
--   alts <- genAltPrinter dataCons tail 0
--   lbl  <- gensym "switch"
--   dflags <- getDynFlags
--   let def_alt = T.ErrT $ "Unknown tag in: " ++ fromVar lbl
--   let bod = if gopt Opt_Packed dflags
--             then T.LetPrimCallT [(tag, T.TagTyPacked), (tail, T.CursorTy)] (T.ReadTag) [(T.VarTriv p)] $
--                  T.Switch lbl (T.VarTriv tag) alts (Just def_alt)
--             else T.LetPrimCallT [(tag, T.TagTyPacked), (tail, T.CursorTy)] (T.ReadScalar IntS) [(T.VarTriv p)] $
--                  T.Switch lbl (T.VarTriv tag) alts (Just def_alt)
--   return T.FunDecl{ T.funName  = mkPrinterName (fromVar tyName),
--                     T.funArgs  = [(p, T.CursorTy)],
--                     T.funRetTy = T.CursorTy,
--                     T.funBody  = bod,
--                     T.isPure   = False
--                   }

printTy :: Bool -> Ty3 -> [T.Triv] -> (T.Tail -> T.Tail)
printTy :: Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
ty [Triv]
trvs =
  case (Ty3
ty, [Triv]
trvs) of
    (Ty3
IntTy, [Triv
_one])             -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.PrintInt [Triv]
trvs
    (Ty3
CharTy, [Triv
_one])            -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.PrintChar [Triv]
trvs
    (Ty3
FloatTy, [Triv
_one])           -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.PrintFloat [Triv]
trvs
    (Ty3
SymTy, [Triv
_one])             -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.PrintSym [Triv]
trvs
    (SymDictTy Maybe Var
_ Ty3
ty', [Triv
_one])     -> (Tail -> Tail) -> [Char] -> Tail -> Tail
sandwich (Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
ty' [Triv]
trvs) [Char]
"Dict"
    (PackedTy [Char]
constr ()
_, [Triv
one]) -> -- HACK: Using varAppend here was the simplest way to get
                                  -- unique names without using the PassM monad.
                                  -- ASSUMPTION: Argument (one) is always a variable reference.
                                  -- This is reasonable because the AST is always flattened before
                                  -- we try to lower it.
                                  -- But we should change this to use gensym anyways..
                                  let T.VarTriv Var
v = Triv
one
                                      unpkd :: Var
unpkd = Var -> Var -> Var
varAppend Var
"unpkd_" Var
v
                                      ignre :: Var
ignre = Var -> Var -> Var
varAppend Var
"ignre_" Var
v
                                  in
                                    if Bool
pkd
                                    then (\Tail
tl -> Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
T.LetCallT Bool
False [(Var
unpkd, Ty
T.PtrTy), (Var
ignre, Ty
T.CursorTy)]
                                                 ([Char] -> Var
mkUnpackerName [Char]
constr) [Triv]
trvs (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
                                                 Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
T.LetCallT Bool
False [] ([Char] -> Var
mkPrinterName [Char]
constr) [Var -> Triv
T.VarTriv Var
unpkd] Tail
tl)
                                    else Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
T.LetCallT Bool
False [] ([Char] -> Var
mkPrinterName [Char]
constr) [Triv]
trvs
    (VectorTy{}, [Triv
_one]) -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.PrintString [Char]
"<vector>") []
    (ListTy{}, [Triv
_one]) -> [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.PrintString [Char]
"<list>") []

    (Ty3
BoolTy, [Triv
trv]) ->
      let prntBool :: [Char] -> Tail -> Tail
prntBool [Char]
m = [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.PrintString [Char]
m) []
      in \Tail
t -> Triv -> Tail -> Tail -> Tail
T.IfT Triv
trv ([Char] -> Tail -> Tail
prntBool [Char]
truePrinted (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail
t) ([Char] -> Tail -> Tail
prntBool [Char]
falsePrinted (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail
t)

    (ProdTy [], [Triv]
_) -> [Char] -> Tail -> Tail
printString [Char]
"'#()"
    (ProdTy{}, [T.ProdTriv [Triv]
trvs]) -> Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
ty [Triv]
trvs
    (ProdTy [Ty3]
tys, [Triv]
_) ->
      let printTupStart :: Tail -> Tail
printTupStart = [Char] -> Tail -> Tail
printString [Char]
"'#("
          ([Triv]
bltrvs,Triv
ltrv) = ([Triv] -> [Triv]
forall a. HasCallStack => [a] -> [a]
init [Triv]
trvs, [Triv] -> Triv
forall a. HasCallStack => [a] -> a
last [Triv]
trvs)
          ([Ty3]
bltys,Ty3
lty)   = ([Ty3] -> [Ty3]
forall a. HasCallStack => [a] -> [a]
init [Ty3]
tys, [Ty3] -> Ty3
forall a. HasCallStack => [a] -> a
last [Ty3]
tys)
      in \Tail
t ->
        Tail -> Tail
printTupStart (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
        ((Ty3, Triv) -> Tail -> Tail) -> Tail -> [(Ty3, Triv)] -> Tail
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Ty3
ty,Triv
trv) Tail
acc -> Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
ty [Triv
trv] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail -> Tail
printSpace Tail
acc)
        (Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
lty [Triv
ltrv] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ Tail -> Tail
closeParen Tail
t)
        ([Ty3] -> [Triv] -> [(Ty3, Triv)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ty3]
bltys [Triv]
bltrvs)
    (Ty3, [Triv])
_ -> [Char] -> Tail -> Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> Tail -> Tail) -> [Char] -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"printTy: unexpected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Ty3, [Triv]) -> [Char]
forall a. Show a => a -> [Char]
show (Ty3
ty, [Triv]
trvs)


-- | In packed mode, keep only the start cursors for packed values
--
-- >>> properTrivs True  (Packedty Tree _) [start,end]
-- [start]
--
-- >>> properTrivs True (ProdTy [IntTy, PackedTy "Tree" _]) [val1, start_cursor_1, end_cursor_1]
-- [val1, start_cursor_1]
--
-- >>> properTrivs True (ProdTy [IntTy,PackedTy "Tree" _, IntTy, PackedTy "Tree _"])
--                 [val1, sc1, ec1, val2, sc2, ec2]
-- [val1, sc1, val2, sc2]
--
-- >>> properTrivs False (Packedty Tree _) [cur]
-- [cur]
--
-- >>> properTrivs False [IntTy,PackedTy "Tree" _, IntTy, PackedTy "Tree _"] [val1, c1, val2, c2]
-- [val1, c1, val2, c2]
properTrivs :: Bool -> Ty3 -> [T.Triv] -> [T.Triv]
properTrivs :: Bool -> Ty3 -> [Triv] -> [Triv]
properTrivs Bool
pkd Ty3
ty [Triv]
trvs =
  if Bool -> Bool
not Bool
pkd then [Triv]
trvs
  else
  case Ty3
ty of
    ProdTy [Ty3]
tys -> [Triv] -> [Ty3] -> [Triv] -> [Triv]
forall {a} {a}. (Out a, Out a) => [a] -> [UrTy a] -> [a] -> [a]
go [] [Ty3]
tys [Triv]
trvs
    PackedTy{} -> [Triv] -> [Triv]
forall a. HasCallStack => [a] -> [a]
init [Triv]
trvs
    Ty3
_ -> [Triv]
trvs
  where
    go :: [a] -> [UrTy a] -> [a] -> [a]
go [a]
acc [] [a]
_trvs = [a]
acc
    go [a]
acc (UrTy a
ty:[UrTy a]
tys) (a
x:[a]
xs) =
      if UrTy a -> Bool
forall a. UrTy a -> Bool
isPackedTy UrTy a
ty
      then [a] -> [UrTy a] -> [a] -> [a]
go ([a]
acc[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a
x]) [UrTy a]
tys ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
L.tail [a]
xs)
      else [a] -> [UrTy a] -> [a] -> [a]
go ([a]
acc[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a
x]) [UrTy a]
tys [a]
xs
    go [a]
_ [UrTy a]
tys [a]
xs = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [a]) -> [Char] -> [a]
forall a b. (a -> b) -> a -> b
$ [Char]
"properTrivs: unexpected tys and trvs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UrTy a] -> [Char]
forall a. Out a => a -> [Char]
sdoc [UrTy a]
tys [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [a] -> [Char]
forall a. Out a => a -> [Char]
sdoc [a]
xs

-- printTy ty trvs = error $ "Invalid L3 data type; " ++ show ty ++ " " ++ show trvs

addPrintToTail :: Ty3 -> T.Tail-> PassM T.Tail
addPrintToTail :: Ty3 -> Tail -> PassM Tail
addPrintToTail Ty3
ty Tail
tl0 = do
    DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
    let pkd :: Bool
pkd = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Packed DynFlags
dflags
        ty' :: Ty
ty' = if Bool
pkd
              then Ty
T.IntTy
              else Ty3 -> Ty
T.fromL3Ty Ty3
ty
    (Tail, Ty) -> ([Triv] -> Tail) -> PassM Tail
forall (m :: * -> *).
MonadState Int m =>
(Tail, Ty) -> ([Triv] -> Tail) -> m Tail
T.withTail (Tail
tl0, Ty
ty') (([Triv] -> Tail) -> PassM Tail) -> ([Triv] -> Tail) -> PassM Tail
forall a b. (a -> b) -> a -> b
$ \ [Triv]
trvs ->
      Bool -> Ty3 -> [Triv] -> Tail -> Tail
printTy Bool
pkd Ty3
ty (Bool -> Ty3 -> [Triv] -> [Triv]
properTrivs Bool
pkd Ty3
ty [Triv]
trvs) (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
        -- Always print a trailing newline at the end of execution:
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.PrintString [Char]
"\n") [] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
          -- T.LetPrimCallT [] T.FreeSymTable [] $
          Tail
T.EndOfMain  -- marker of the end of main expression

-- | Look up the numeric tag for a dataCon
getTagOfDataCon :: Out a => DDefs a -> DataCon -> Tag
getTagOfDataCon :: forall a. Out a => DDefs a -> [Char] -> Tag
getTagOfDataCon DDefs a
dds [Char]
dcon =
    if [Char] -> Bool
isIndirectionTag [Char]
dcon
    then Tag
forall a. Num a => a
indirectionAlt
    else if [Char] -> Bool
isRedirectionTag [Char]
dcon
    then Tag
forall a. Num a => a
redirectionAlt
    else if [Char] -> Bool
isRelRANDataCon [Char]
dcon
    -- So that is_big in the RTS can identify which nodes have size information.
    then Tag
150 Tag -> Tag -> Tag
forall a. Num a => a -> a -> a
+ (Int -> Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)
    else Int -> Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix
  where Just Int
ix = [Char] -> [[Char]] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex [Char]
dcon ([[Char]] -> Maybe Int) -> [[Char]] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ DDefs a -> [Char] -> [[Char]]
forall a. Out a => DDefs a -> [Char] -> [[Char]]
getConOrdering DDefs a
dds (Var -> [Char]
fromVar Var
tycon)
        (Var
tycon,([Char], [(Bool, a)])
_) = DDefs a -> [Char] -> (Var, ([Char], [(Bool, a)]))
forall a.
Out a =>
DDefs a -> [Char] -> (Var, ([Char], [(Bool, a)]))
lkp DDefs a
dds [Char]
dcon


-- The compiler pass
-------------------------------------------------------------------------------a

-- | Convert into the target language.  This does not make much of a
-- change, but it checks the changes that have already occurred.
--
-- The only substantitive conversion here is of tupled arguments to
-- multiple argument functions.
--
-- First argument indicates (1) whether we're inpacked mode, and (2)
-- the pre-cursorize type of the mainExp, if there is a mainExp.
lower :: Prog3 -> PassM T.Prog
lower :: Prog3 -> PassM Prog
lower Prog{FunDefs (PreExp E3Ext () Ty3)
fundefs :: FunDefs (PreExp E3Ext () Ty3)
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs,DDefs (TyOf (PreExp E3Ext () Ty3))
ddefs :: DDefs (TyOf (PreExp E3Ext () Ty3))
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs,Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
mainExp :: Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} = do
  -- In Lower, we want to replace LitSymE's with the corresponding index into
  -- the symbol table. That's why we build a map from String's to Int64's.
  -- However, all the subsequent lookup's will be on the index, to get to the
  -- String. So we store an inverse of this map in a L4 program. Because we've
  -- built the map with `gensym`, it's safe to assume that the indices are
  -- unique.
  -- inv_sym_tbl :: M.Map String Word16
  Map [Char] Word16
inv_sym_tbl <- PassM (Map [Char] Word16)
build_inv_symbol_table
  -- sym_tbl :: M.Map Int64 String
  let sym_tbl :: Map Word16 [Char]
sym_tbl = [(Word16, [Char])] -> Map Word16 [Char]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Word16, [Char])] -> Map Word16 [Char])
-> [(Word16, [Char])] -> Map Word16 [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], Word16) -> (Word16, [Char]))
-> [([Char], Word16)] -> [(Word16, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Word16) -> (Word16, [Char])
forall a b. (a, b) -> (b, a)
swap (Map [Char] Word16 -> [([Char], Word16)]
forall k a. Map k a -> [(k, a)]
M.toList Map [Char] Word16
inv_sym_tbl)

  let info_tbl :: InfoTable
info_tbl = InfoTable
build_info_table

  Maybe MainExp
mn <- case Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
mainExp of
          Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
Nothing    -> Maybe MainExp -> PassM (Maybe MainExp)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MainExp
forall a. Maybe a
Nothing
          Just (PreExp E3Ext () Ty3
x,TyOf (PreExp E3Ext () Ty3)
mty) -> (MainExp -> Maybe MainExp
forall a. a -> Maybe a
Just (MainExp -> Maybe MainExp)
-> (Tail -> MainExp) -> Tail -> Maybe MainExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MainExp
T.PrintExp) (Tail -> Maybe MainExp) -> PassM Tail -> PassM (Maybe MainExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            (Ty3 -> Tail -> PassM Tail
addPrintToTail TyOf (PreExp E3Ext () Ty3)
Ty3
mty (Tail -> PassM Tail) -> PassM Tail -> PassM Tail
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
True Map [Char] Word16
inv_sym_tbl PreExp E3Ext () Ty3
x)
  [FunDecl]
funs       <- (FunDef (PreExp E3Ext () Ty3) -> PassM FunDecl)
-> [FunDef (PreExp E3Ext () Ty3)] -> PassM [FunDecl]
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 (Map [Char] Word16 -> FunDef (PreExp E3Ext () Ty3) -> PassM FunDecl
fund Map [Char] Word16
inv_sym_tbl) (FunDefs (PreExp E3Ext () Ty3) -> [FunDef (PreExp E3Ext () Ty3)]
forall k a. Map k a -> [a]
M.elems FunDefs (PreExp E3Ext () Ty3)
fundefs)
  DynFlags
dflags     <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
  [FunDecl]
unpackers  <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pointer DynFlags
dflags
                then (DDef Ty3 -> PassM FunDecl) -> [DDef Ty3] -> PassM [FunDecl]
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 DDef Ty3 -> PassM FunDecl
genUnpacker ((DDef Ty3 -> Bool) -> [DDef Ty3] -> [DDef Ty3]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not (Bool -> Bool) -> (DDef Ty3 -> Bool) -> DDef Ty3 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DDef Ty3 -> Bool
forall a. DDef a -> Bool
isVoidDDef) (Map Var (DDef Ty3) -> [DDef Ty3]
forall k a. Map k a -> [a]
M.elems DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs))
                else [FunDecl] -> PassM [FunDecl]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (InfoTable
-> Map Word16 [Char] -> [FunDecl] -> Maybe MainExp -> Prog
T.Prog InfoTable
info_tbl Map Word16 [Char]
sym_tbl) ([FunDecl] -> Maybe MainExp -> Prog)
-> PassM [FunDecl] -> PassM (Maybe MainExp -> Prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FunDecl] -> PassM [FunDecl]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FunDecl]
funs [FunDecl] -> [FunDecl] -> [FunDecl]
forall a. [a] -> [a] -> [a]
++ [FunDecl]
unpackers) PassM (Maybe MainExp -> Prog)
-> PassM (Maybe MainExp) -> PassM Prog
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe MainExp -> PassM (Maybe MainExp)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MainExp
mn
 where
  fund :: M.Map String Word16 -> FunDef3 -> PassM T.FunDecl
  fund :: Map [Char] Word16 -> FunDef (PreExp E3Ext () Ty3) -> PassM FunDecl
fund Map [Char] Word16
sym_tbl FunDef{Var
funName :: Var
funName :: forall ex. FunDef ex -> Var
funName,ArrowTy (TyOf (PreExp E3Ext () Ty3))
funTy :: ArrowTy (TyOf (PreExp E3Ext () Ty3))
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy,[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,PreExp E3Ext () Ty3
funBody :: PreExp E3Ext () Ty3
funBody :: forall ex. FunDef ex -> ex
funBody} = do
      let ([Ty3]
intys, Ty3
outty) = ArrowTy (TyOf (PreExp E3Ext () Ty3))
funTy
      let ([(Var, Ty)]
args, PreExp E3Ext () Ty3
bod) = ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs ((Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map Ty3 -> Ty
typ [Ty3]
intys), PreExp E3Ext () Ty3
funBody)
      Tail
bod' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail (Bool -> Bool
not (Ty3 -> Bool
hasCursorTy Ty3
outty)) Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      FunDecl -> PassM FunDecl
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return T.FunDecl{ funName :: Var
T.funName  = Var
funName
                      , funArgs :: [(Var, Ty)]
T.funArgs  = [(Var, Ty)]
args
                      , funRetTy :: Ty
T.funRetTy = Ty3 -> Ty
typ Ty3
outty
                      , funBody :: Tail
T.funBody  = Tail
bod'
                      , isPure :: Bool
T.isPure   = PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
funBody
                      }

  build_info_table :: T.InfoTable
  build_info_table :: InfoTable
build_info_table =
      (DDef Ty3 -> InfoTable -> InfoTable)
-> InfoTable -> Map Var (DDef Ty3) -> InfoTable
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr
          (\DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName,[([Char], [(Bool, Ty3)])]
dataCons :: forall a. DDef a -> [([Char], [(Bool, a)])]
dataCons :: [([Char], [(Bool, Ty3)])]
dataCons} InfoTable
acc ->
               [Char] -> TyConInfo -> InfoTable -> InfoTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
                   (Var -> [Char]
fromVar Var
tyName)
                   ((([Char], [(Bool, Ty3)]) -> TyConInfo -> TyConInfo)
-> TyConInfo -> [([Char], [(Bool, Ty3)])] -> TyConInfo
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\([Char]
dcon,[(Bool, Ty3)]
tys) TyConInfo
dcon_acc ->
                             if [Char] -> Bool
isIndirectionTag [Char]
dcon Bool -> Bool -> Bool
|| [Char] -> Bool
isRedirectionTag [Char]
dcon
                             then TyConInfo
dcon_acc
                             else [Char] -> DataConInfo -> TyConInfo -> TyConInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
dcon ([Char] -> [(Bool, Ty3)] -> DataConInfo
go [Char]
dcon [(Bool, Ty3)]
tys) TyConInfo
dcon_acc)
                          TyConInfo
forall k a. Map k a
M.empty
                          [([Char], [(Bool, Ty3)])]
dataCons)
                   InfoTable
acc)
          InfoTable
forall k a. Map k a
M.empty
          DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs
      where
        go :: [Char] -> [(Bool, Ty3)] -> DataConInfo
go [Char]
dcon [(Bool, Ty3)]
tys =
            let field_tys :: [Ty3]
field_tys = ((Bool, Ty3) -> Ty3) -> [(Bool, Ty3)] -> [Ty3]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Ty3) -> Ty3
forall a b. (a, b) -> b
snd [(Bool, Ty3)]
tys
                (Int
num_packed,Int
num_scalars) = (\([Ty3]
a,[Ty3]
b) ->
                                              let b' :: [Ty3]
b' = (Ty3 -> Bool) -> [Ty3] -> [Ty3]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Ty3
x -> case Ty3
x of
                                                                       Ty3
CursorTy -> Bool
False
                                                                       Ty3
_ -> Bool
True)
                                                              [Ty3]
b
                                              in ([Ty3] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ty3]
a, [Ty3] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ty3]
b')) (([Ty3], [Ty3]) -> (Int, Int)) -> ([Ty3], [Ty3]) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$
                                           (Ty3 -> Bool) -> [Ty3] -> ([Ty3], [Ty3])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Ty3 -> Bool
forall a. UrTy a -> Bool
isPackedTy [Ty3]
field_tys
                (Int
scalar_bytes, Int
num_shortcut) =
                               ((Int, Int) -> Ty3 -> (Int, Int))
-> (Int, Int) -> [Ty3] -> (Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(Int
acc1,Int
acc2) Ty3
ty ->
                                          case Ty3
ty of
                                            PackedTy{} -> (Int
acc1,Int
acc2)
                                            Ty3
CursorTy -> (Int
acc1, Int
acc2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                                            Ty3
_ -> (Int
acc1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Ty3 -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy Ty3
ty), Int
acc2))
                                     (Int
0,Int
0) [Ty3]
field_tys
                dcon_tag :: Tag
dcon_tag = Map Var (DDef Ty3) -> [Char] -> Tag
forall a. Out a => DDefs a -> [Char] -> Tag
getTagOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
dcon
            in (Tag -> Int -> Int -> Int -> Int -> [Ty3] -> DataConInfo
T.DataConInfo Tag
dcon_tag Int
scalar_bytes Int
num_shortcut Int
num_scalars Int
num_packed [Ty3]
field_tys)


  hasCursorTy :: Ty3 -> Bool
  hasCursorTy :: Ty3 -> Bool
hasCursorTy Ty3
CursorTy = Bool
True
  hasCursorTy (ProdTy [Ty3]
tys) = (Ty3 -> Bool) -> [Ty3] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Ty3 -> Bool
hasCursorTy [Ty3]
tys
  hasCursorTy Ty3
_ = Bool
False

  -- TimeIt forms are impure because they have print statements after codegen
  ispure :: Exp3 -> Bool
  ispure :: PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
ex =
    case PreExp E3Ext () Ty3
ex of
      TimeIt{} -> Bool
False
      PrimAppE Prim Ty3
Gensym [] -> Bool
False
      PrimAppE Prim Ty3
RandP []  -> Bool
False
      PrimAppE Prim Ty3
FRandP []  -> Bool
False
      LetE (Var
_,[()]
_,Ty3
_,PreExp E3Ext () Ty3
rhs) PreExp E3Ext () Ty3
bod -> PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
rhs Bool -> Bool -> Bool
&& PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
bod
      IfE PreExp E3Ext () Ty3
_ PreExp E3Ext () Ty3
b PreExp E3Ext () Ty3
c   -> PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
b Bool -> Bool -> Bool
&& PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
c
      CaseE PreExp E3Ext () Ty3
_ [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
brs -> (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (([Char], [(Var, ())], PreExp E3Ext () Ty3) -> Bool)
-> [([Char], [(Var, ())], PreExp E3Ext () Ty3)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
L.map (\([Char]
_,[(Var, ())]
_,PreExp E3Ext () Ty3
rhs) -> PreExp E3Ext () Ty3 -> Bool
ispure PreExp E3Ext () Ty3
rhs) [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
brs
      PreExp E3Ext () Ty3
_ -> Bool
True

  build_inv_symbol_table :: PassM (M.Map String Word16)
  build_inv_symbol_table :: PassM (Map [Char] Word16)
build_inv_symbol_table = ([Char] -> Map [Char] Word16 -> PassM (Map [Char] Word16))
-> Map [Char] Word16 -> Set [Char] -> PassM (Map [Char] Word16)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\[Char]
s Map [Char] Word16
acc -> case [Char] -> Map [Char] Word16 -> Maybe Word16
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
s Map [Char] Word16
acc of
                                           Just{}  -> Map [Char] Word16 -> PassM (Map [Char] Word16)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map [Char] Word16
acc
                                           Maybe Word16
Nothing -> do
                                             Word16
uniq <- Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> PassM Int -> PassM Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassM Int
forall (m :: * -> *). MonadState Int m => m Int
newUniq
                                             Map [Char] Word16 -> PassM (Map [Char] Word16)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Word16 -> Map [Char] Word16 -> Map [Char] Word16
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
s Word16
uniq Map [Char] Word16
acc))
                              Map [Char] Word16
forall k a. Map k a
M.empty Set [Char]
all_syms
    where
      all_syms :: S.Set String
      all_syms :: Set [Char]
all_syms = (case Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
mainExp of
                    Maybe (PreExp E3Ext () Ty3, TyOf (PreExp E3Ext () Ty3))
Nothing    -> Set [Char]
forall a. Set a
S.empty
                    Just (PreExp E3Ext () Ty3
e,TyOf (PreExp E3Ext () Ty3)
_) -> Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
forall a. Set a
S.empty PreExp E3Ext () Ty3
e) Set [Char] -> Set [Char] -> Set [Char]
forall a. Semigroup a => a -> a -> a
<>
                 ((Set [Char] -> FunDef (PreExp E3Ext () Ty3) -> Set [Char])
-> Set [Char] -> FunDefs (PreExp E3Ext () Ty3) -> Set [Char]
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl (\Set [Char]
acc FunDef (PreExp E3Ext () Ty3)
fn -> Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
acc (FunDef (PreExp E3Ext () Ty3) -> PreExp E3Ext () Ty3
forall ex. FunDef ex -> ex
funBody FunDef (PreExp E3Ext () Ty3)
fn)) Set [Char]
forall a. Set a
S.empty FunDefs (PreExp E3Ext () Ty3)
fundefs)


      collect_syms :: S.Set String -> Exp3 -> S.Set String
      collect_syms :: Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
syms PreExp E3Ext () Ty3
ex =
        let go :: PreExp E3Ext () Ty3 -> Set [Char]
go  = Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
syms
            gol :: [PreExp E3Ext () Ty3] -> Set [Char]
gol = (Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char])
-> Set [Char] -> [PreExp E3Ext () Ty3] -> Set [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
syms in
        case PreExp E3Ext () Ty3
ex of
          VarE{}    -> Set [Char]
syms
          LitE{}    -> Set [Char]
syms
          CharE{}   -> Set [Char]
syms
          FloatE{}  -> Set [Char]
syms
          LitSymE Var
v -> [Char] -> Set [Char] -> Set [Char]
forall a. Ord a => a -> Set a -> Set a
S.insert (Var -> [Char]
fromVar Var
v) Set [Char]
syms
          AppE Var
_ [()]
_ [PreExp E3Ext () Ty3]
args   -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
args
          PrimAppE Prim Ty3
_ [PreExp E3Ext () Ty3]
args -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
args
          LetE (Var
_,[()]
_,Ty3
_,PreExp E3Ext () Ty3
rhs) PreExp E3Ext () Ty3
bod -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
rhs Set [Char] -> Set [Char] -> Set [Char]
forall a. Semigroup a => a -> a -> a
<> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
bod
          IfE PreExp E3Ext () Ty3
a PreExp E3Ext () Ty3
b PreExp E3Ext () Ty3
c  -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
a Set [Char] -> Set [Char] -> Set [Char]
forall a. Semigroup a => a -> a -> a
<> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
b Set [Char] -> Set [Char] -> Set [Char]
forall a. Semigroup a => a -> a -> a
<> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
c
          MkProdE [PreExp E3Ext () Ty3]
ls -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
ls
          ProjE Int
_ PreExp E3Ext () Ty3
e  -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
e
          CaseE PreExp E3Ext () Ty3
scrt [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls ->
            PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
scrt Set [Char] -> Set [Char] -> Set [Char]
forall a. Semigroup a => a -> a -> a
<> (Set [Char]
 -> ([Char], [(Var, ())], PreExp E3Ext () Ty3) -> Set [Char])
-> Set [Char]
-> [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
-> Set [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Set [Char]
acc ([Char]
_,[(Var, ())]
_,PreExp E3Ext () Ty3
c) -> Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
acc PreExp E3Ext () Ty3
c) Set [Char]
syms [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls
          DataConE ()
_ [Char]
_ [PreExp E3Ext () Ty3]
ls -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
ls
          TimeIt PreExp E3Ext () Ty3
e Ty3
_ Bool
_   -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
e
          WithArenaE Var
_ PreExp E3Ext () Ty3
e -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
e
          SpawnE Var
_ [()]
_ [PreExp E3Ext () Ty3]
ls  -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
ls
          PreExp E3Ext () Ty3
SyncE -> Set [Char]
forall a. Set a
S.empty
          Ext E3Ext () Ty3
ext        ->
            case E3Ext () Ty3
ext of
              WriteScalar Scalar
_ Var
_ PreExp E3Ext () Ty3
ex -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
              AddCursor Var
_ PreExp E3Ext () Ty3
ex   -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
              SubPtr{}         -> Set [Char]
syms
              WriteCursor Var
_ PreExp E3Ext () Ty3
ex -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
              TagCursor{}    -> Set [Char]
syms
              ReadScalar{}   -> Set [Char]
syms
              ReadTag{}      -> Set [Char]
syms
              WriteTag{}     -> Set [Char]
syms
              ReadList{}     -> Set [Char]
syms
              WriteList Var
_ PreExp E3Ext () Ty3
ex Ty3
_ -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
              ReadVector{}     -> Set [Char]
syms
              WriteVector Var
_ PreExp E3Ext () Ty3
ex Ty3
_ -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
              NewBuffer{}        -> Set [Char]
syms
              NewParBuffer{}     -> Set [Char]
syms
              ScopedBuffer{}     -> Set [Char]
syms
              ScopedParBuffer{}  -> Set [Char]
syms
              EndOfBuffer{}      -> Set [Char]
syms
              MMapFileSize{}     -> Set [Char]
syms
              SizeOfPacked{}     -> Set [Char]
syms
              SizeOfScalar{}     -> Set [Char]
syms
              BoundsCheck{}      -> Set [Char]
syms
              ReadCursor{}       -> Set [Char]
syms
              WriteTaggedCursor{}-> Set [Char]
syms
              ReadTaggedCursor{} -> Set [Char]
syms
              IndirectionBarrier{} -> Set [Char]
syms
              E3Ext () Ty3
NullCursor         -> Set [Char]
syms
              BumpArenaRefCount{}-> [Char] -> Set [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"collect_syms: BumpArenaRefCount not handled."
              RetE [PreExp E3Ext () Ty3]
ls -> [PreExp E3Ext () Ty3] -> Set [Char]
gol [PreExp E3Ext () Ty3]
ls
              E3Ext () Ty3
GetCilkWorkerNum -> Set [Char]
syms
              LetAvail [Var]
_ PreExp E3Ext () Ty3
bod   -> Set [Char] -> PreExp E3Ext () Ty3 -> Set [Char]
collect_syms Set [Char]
syms PreExp E3Ext () Ty3
bod
              AllocateTagHere{} -> Set [Char]
syms
              AllocateScalarsHere{} -> Set [Char]
syms
              StartTagAllocation{} -> Set [Char]
syms
              EndTagAllocation{} -> Set [Char]
syms
              StartScalarsAllocation{} -> Set [Char]
syms
              EndScalarsAllocation{} -> Set [Char]
syms
              SSPush{} -> Set [Char]
syms
              SSPop{} -> Set [Char]
syms
              Assert PreExp E3Ext () Ty3
ex -> PreExp E3Ext () Ty3 -> Set [Char]
go PreExp E3Ext () Ty3
ex
          MapE{}         -> Set [Char]
syms
          FoldE{}        -> Set [Char]
syms


  tail :: Bool -> M.Map String Word16 -> Exp3 -> PassM T.Tail
  tail :: Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
ex0 = do
   DynFlags
dflags <- PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
   let pkd :: Bool
pkd = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Packed DynFlags
dflags
   case PreExp E3Ext () Ty3
ex0 of

    -- HACK! We don't have LetSwitchT yet.  This means potential exponential code duplication:
    -- LetE (_,_, CaseE _ _) _ ->
    --    error "lower: unfinished, we cannot let-bind the result of a switch yet."
    LetE (Var
vr,[()]
_locs,Ty3
ty, (CaseE PreExp E3Ext () Ty3
scrt [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls)) PreExp E3Ext () Ty3
bod -> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl (PreExp E3Ext () Ty3 -> PassM Tail)
-> PreExp E3Ext () Ty3 -> PassM Tail
forall a b. (a -> b) -> a -> b
$
                                       Int -> [Char] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a. Int -> [Char] -> a -> a
dbgTrace Int
1 ([Char]
"WARNING: Let-bound CasE, code duplication of this body:\n  "
                                                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
bod)(PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
         -- For now just duplicate code:
         PreExp E3Ext () Ty3
-> [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
-> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp E3Ext () Ty3
scrt [ ([Char]
k,[(Var, ())]
vs, (Var, Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
mkLet (Var
vr,Ty3
ty,PreExp E3Ext () Ty3
e) PreExp E3Ext () Ty3
bod)
                    | ([Char]
k,[(Var, ())]
vs,PreExp E3Ext () Ty3
e) <- [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls]

    -- Aaand... if we're going to push Let's under Case's, we have to repeat this bit of flattening:
    LetE (Var
v1, [()]
locs, Ty3
t1, (LetE (Var
v2,[()]
locs2,Ty3
t2,PreExp E3Ext () Ty3
rhs2) PreExp E3Ext () Ty3
rhs1)) PreExp E3Ext () Ty3
bod ->
       Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl (PreExp E3Ext () Ty3 -> PassM Tail)
-> PreExp E3Ext () Ty3 -> PassM Tail
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v2,[()]
locs,Ty3
t2,PreExp E3Ext () Ty3
rhs2) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v1,[()]
locs2,Ty3
t1,PreExp E3Ext () Ty3
rhs1) PreExp E3Ext () Ty3
bod

    --------------------------------------------------------------------------------
    -- Packed codegen
    --------------------------------------------------------------------------------

    -- Likewise, Case really means ReadTag.  Argument is a cursor.
    CaseE (VarE Var
scrut) [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls | Bool
pkd -> do
        Var
tagtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpval"
        Var
ctmp   <- 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
$ [Char] -> Var
toVar [Char]
"tmpcur"
        -- Here we lamely chase down all the tuple references and make them variables:
        -- So that Goto's work properly (See [Modifying switch statements to use redirection nodes]).
        let doalt :: ([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Tag, Tail)
doalt ([Char]
k,[(Var, ())]
ls,PreExp E3Ext () Ty3
rhs) = do
              let rhs' :: PreExp E3Ext () Ty3
rhs' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreExp E3Ext () Ty3 -> E3Ext () Ty3
forall loc dec. Var -> PreExp E3Ext loc dec -> E3Ext loc dec
AddCursor Var
scrut (Int -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
1))) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                         PreExp E3Ext () Ty3
rhs
              -- We only need to thread one value through, the cursor resulting from read.
              (Map Var (DDef Ty3) -> [Char] -> Tag
forall a. Out a => DDefs a -> [Char] -> Tag
getTagOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
k,) (Tail -> (Tag, Tail)) -> PassM Tail -> PassM (Tag, Tail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                case [(Var, ())]
ls of
                  []  -> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
rhs' -- AUDITME -- is this legit, or should it have one cursor param anyway?
                  [(Var
c,()
_)] -> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl (Var
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst Var
c (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp) PreExp E3Ext () Ty3
rhs')
                  [(Var, ())]
oth -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower.tail.CaseE: unexpected pattern" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [(Var, ())] -> [Char]
forall a. Show a => a -> [Char]
show [(Var, ())]
oth
        [(Tag, Tail)]
alts <- (([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Tag, Tail))
-> [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
-> PassM [(Tag, Tail)]
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 ([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Tag, Tail)
doalt [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
ls
        let def_alt :: Tail
def_alt = [Char] -> Tail
T.ErrT ([Char] -> Tail) -> [Char] -> Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown tag in: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
tagtmp
        Var
lbl <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"switch"
        Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$
         [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
tagtmp,Ty
T.TagTyPacked),(Var
ctmp,Ty
T.CursorTy)] Prim
T.ReadTag [Var -> Triv
T.VarTriv Var
scrut] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
          Var -> Triv -> Alts -> Maybe Tail -> Tail
T.Switch Var
lbl
                   (Var -> Triv
T.VarTriv Var
tagtmp)
                   ([(Tag, Tail)] -> Alts
T.TagAlts [(Tag, Tail)]
alts)
                   (Tail -> Maybe Tail
forall a. a -> Maybe a
Just Tail
def_alt)

    --------------------------------------------------------------------------------
    -- Not-packed, pointer-based codegen
    --------------------------------------------------------------------------------
    -- In pointer-based representation we don't use `TagTyPacked`, because it is
    -- causing problems.  By default gcc aligns struct fields but we don't
    -- take that padding into account in our codegen.
    --
    -- If we get here that means we're NOT packing trees on this run:
    -- Thus this operates on BOXED data:
    CaseE PreExp E3Ext () Ty3
e [([Char]
c, [(Var, ())]
bndrs, PreExp E3Ext () Ty3
rhs)] | Bool -> Bool
not Bool
pkd -> do
      -- a product, directly assign the fields
      let tys :: [Ty]
tys = (Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ (Map Var (DDef Ty3) -> [Char] -> [Ty3]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
c)
          ([Var]
bndrs2,[()]
_) = [(Var, ())] -> ([Var], [()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, ())]
bndrs

      -- TODO(osa): enable this
      -- ASSERT(length tys == length bndrs)

      let T.VarTriv Var
e_var = Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"product case scrutinee" PreExp E3Ext () Ty3
e
      Var
tag_bndr  <- 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
$ [Char] -> Var
toVar [Char]
"tag"

      let bndrs' :: [Var]
bndrs' = Var
tag_bndr Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
bndrs2
          tys' :: [Ty]
tys'   = Ty
T.IntTy  Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
: [Ty]
tys
      Tail
rhs' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
rhs
      Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, Ty)] -> Var -> Tail -> Tail
T.LetUnpackT ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
bndrs' [Ty]
tys') Var
e_var Tail
rhs')

    CaseE PreExp E3Ext () Ty3
e [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
alts | Bool -> Bool
not Bool
pkd -> do
      Var
tag_bndr <- 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
$ [Char] -> Var
toVar [Char]
"tag"
      Var
tail_bndr <- 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
$ [Char] -> Var
toVar [Char]
"tail"

      let
        e_triv :: Triv
e_triv = Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"sum case scrutinee" PreExp E3Ext () Ty3
e

        mk_alt :: (DataCon, [(Var,())], Exp3) -> PassM (Int64, T.Tail)
        mk_alt :: ([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Int64, Tail)
mk_alt ([Char]
con, [(Var, ())]
bndrs, PreExp E3Ext () Ty3
rhs) = do
          let
            con_tag :: Tag
con_tag = Map Var (DDef Ty3) -> [Char] -> Tag
forall a. Out a => DDefs a -> [Char] -> Tag
getTagOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
con
            bndr_tys :: [Ty]
bndr_tys = (Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ (Map Var (DDef Ty3) -> [Char] -> [Ty3]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
con)
            ([Var]
bndrs',[()]
_) = [(Var, ())] -> ([Var], [()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, ())]
bndrs
          Tail
rhs' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
rhs
          (Int64, Tail) -> PassM (Int64, Tail)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Tag -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tag
con_tag, [(Var, Ty)] -> Var -> Tail -> Tail
T.LetUnpackT ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
bndrs' [Ty]
bndr_tys) Var
tail_bndr Tail
rhs' )

      [(Int64, Tail)]
alts' <- (([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Int64, Tail))
-> [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
-> PassM [(Int64, Tail)]
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 ([Char], [(Var, ())], PreExp E3Ext () Ty3) -> PassM (Int64, Tail)
mk_alt [([Char], [(Var, ())], PreExp E3Ext () Ty3)]
alts
      let def_alt :: Tail
def_alt = [Char] -> Tail
T.ErrT ([Char] -> Tail) -> [Char] -> Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown tag in: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
tag_bndr
      Var
lbl <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"switch"

      Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT
          [(Var
tag_bndr, Ty
T.TagTyPacked), (Var
tail_bndr, Ty
T.CursorTy)]
          (Scalar -> Prim
T.ReadScalar Scalar
IntS)
          [Triv
e_triv]
          (Var -> Triv -> Alts -> Maybe Tail -> Tail
T.Switch Var
lbl (Var -> Triv
T.VarTriv Var
tag_bndr) ([(Int64, Tail)] -> Alts
T.IntAlts [(Int64, Tail)]
alts') (Tail -> Maybe Tail
forall a. a -> Maybe a
Just Tail
def_alt))


    -- Accordingly, constructor allocation becomes an allocation.
    LetE (Var
v, [()]
_, Ty3
_, (DataConE ()
_ [Char]
k [PreExp E3Ext () Ty3]
ls)) PreExp E3Ext () Ty3
bod | Bool -> Bool
not Bool
pkd -> [PreExp E3Ext () Ty3] -> PassM Tail -> PassM Tail
forall e a. (HasCallStack, Expression e) => [e] -> a -> a
L3.assertTrivs [PreExp E3Ext () Ty3]
ls (PassM Tail -> PassM Tail) -> PassM Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ do
      let tycon :: [Char]
tycon    = Map Var (DDef Ty3) -> [Char] -> [Char]
forall a. Out a => DDefs a -> [Char] -> [Char]
getTyOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
k
          all_cons :: [([Char], [(Bool, Ty3)])]
all_cons = DDef Ty3 -> [([Char], [(Bool, Ty3)])]
forall a. DDef a -> [([Char], [(Bool, a)])]
dataCons (Map Var (DDef Ty3) -> [Char] -> DDef Ty3
forall a. Out a => DDefs a -> [Char] -> DDef a
lookupDDef DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
tycon)
          tag :: Int
tag      = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust ((([Char], [(Bool, Ty3)]) -> Bool)
-> [([Char], [(Bool, Ty3)])] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Char]
k ([Char] -> Bool)
-> (([Char], [(Bool, Ty3)]) -> [Char])
-> ([Char], [(Bool, Ty3)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [(Bool, Ty3)]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [(Bool, Ty3)])]
all_cons)

          field_tys :: [Ty]
field_tys= (Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ (Map Var (DDef Ty3) -> [Char] -> [Ty3]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
k)
          fields0 :: [(Ty, Triv)]
fields0  = [Ty] -> [Triv] -> [(Ty, Triv)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Ty]
field_tys ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
L.map (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"DataConE args") [PreExp E3Ext () Ty3]
ls)
          fields :: [(Ty, Triv)]
fields   = (Ty
T.IntTy, Int64 -> Triv
T.IntTriv (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag)) (Ty, Triv) -> [(Ty, Triv)] -> [(Ty, Triv)]
forall a. a -> [a] -> [a]
: [(Ty, Triv)]
fields0
          --  | is_prod   = fields0
          --  | otherwise = (T.IntTy, T.IntTriv (fromIntegral tag)) : fields0
      Tail
bod' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> [(Ty, Triv)] -> Tail -> Tail
T.LetAllocT Var
v [(Ty, Triv)]
fields Tail
bod')


    -- This is legitimately flattened, but we need to move it off the spine:
    DataConE ()
_ [Char]
k [PreExp E3Ext () Ty3]
_ls -> do
       Var
tmp <- 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
$ [Char] -> Var
toVar [Char]
"tailift"
       let ty :: Ty3
ty = [Char] -> () -> Ty3
forall loc. [Char] -> loc -> UrTy loc
L3.PackedTy (Map Var (DDef Ty3) -> [Char] -> [Char]
forall a. Out a => DDefs a -> [Char] -> [Char]
getTyOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
k) ()
       Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl (PreExp E3Ext () Ty3 -> PassM Tail)
-> PreExp E3Ext () Ty3 -> PassM Tail
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
tmp, [], Ty3
ty, PreExp E3Ext () Ty3
ex0) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp)

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

    -- Ext (RetE ls)   -> pure$ T.RetValsT (L.map (triv sym_tbl "returned element of tuple") ls)
    --
    MkProdE [PreExp E3Ext () Ty3]
ls      -> Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure(Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Triv] -> Tail
T.RetValsT ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
L.map (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"returned element of tuple") [PreExp E3Ext () Ty3]
ls)
    PreExp E3Ext () Ty3
e | PreExp E3Ext () Ty3 -> Bool
forall e. Expression e => e -> Bool
isTrivial PreExp E3Ext () Ty3
e -> Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure(Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Triv] -> Tail
T.RetValsT [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"<internal error1>" (PreExp E3Ext () Ty3
e)]

    -- We could eliminate these ahead of time (unariser):
    -- FIXME: Remove this when that is done a priori:
    LetE (Var
v, [()]
_, ProdTy [Ty3]
tys, (MkProdE [PreExp E3Ext () Ty3]
ls)) PreExp E3Ext () Ty3
bod -> do
      ([Var]
tmps,PreExp E3Ext () Ty3
bod') <- Var
-> [Ty3]
-> PreExp E3Ext () Ty3
-> PassM ([Var], PreExp E3Ext () Ty3)
eliminateProjs Var
v [Ty3]
tys PreExp E3Ext () Ty3
bod
      let bod'' :: PreExp E3Ext () Ty3
bod'' = [Var] -> [Var] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
updateAvailVars [Var
v] [Var]
tmps PreExp E3Ext () Ty3
bod'
      -- Bind tmps individually:a
      let go :: [(Var, dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
go [] PreExp ext loc dec
acc                 = PreExp ext loc dec
acc
          go ((Var
pvr,dec
pty,PreExp ext loc dec
rhs):[(Var, dec, PreExp ext loc dec)]
rs) PreExp ext loc dec
acc = [(Var, dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
go [(Var, dec, PreExp ext loc dec)]
rs ((Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
pvr,[],dec
pty,PreExp ext loc dec
rhs) PreExp ext loc dec
acc)
      -- Finally reprocess the whole thing
      Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl ([(Var, Ty3, PreExp E3Ext () Ty3)]
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall {dec} {ext :: * -> * -> *} {loc}.
[(Var, dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
go ([Var]
-> [Ty3]
-> [PreExp E3Ext () Ty3]
-> [(Var, Ty3, PreExp E3Ext () Ty3)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Var]
tmps [Ty3]
tys [PreExp E3Ext () Ty3]
ls) PreExp E3Ext () Ty3
bod'')

    LetE (Var
v, [()]
_, Ty3
ty, rhs :: PreExp E3Ext () Ty3
rhs@(ProjE{})) PreExp E3Ext () Ty3
bod -> do
      let trv :: Triv
trv = Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"ProjE" PreExp E3Ext () Ty3
rhs
      Tail
bod' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ (Var, Ty, Triv) -> Tail -> Tail
T.LetTrivT (Var
v,Ty3 -> Ty
typ Ty3
ty,Triv
trv) Tail
bod'

    WithArenaE Var
v PreExp E3Ext () Ty3
e -> do
      Tail
e' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
e
      Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ Var -> Tail -> Tail
T.LetArenaT Var
v Tail
e'

    -- We could eliminate these ahead of time:
    LetE (Var
v,[()]
_,Ty3
t,PreExp E3Ext () Ty3
rhs) PreExp E3Ext () Ty3
bod | PreExp E3Ext () Ty3 -> Bool
isTrivial' PreExp E3Ext () Ty3
rhs ->
      (Var, Ty, Triv) -> Tail -> Tail
T.LetTrivT (Var
v,Ty3 -> Ty
typ Ty3
t, Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"<internal error2>" PreExp E3Ext () Ty3
rhs) (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    IfE PreExp E3Ext () Ty3
a PreExp E3Ext () Ty3
b PreExp E3Ext () Ty3
c -> do Tail
b' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
b
                    Tail
c' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
c
                    Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ Triv -> Tail -> Tail -> Tail
T.IfT (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"if test" PreExp E3Ext () Ty3
a) Tail
b' Tail
c'

    LetE (Var
vr, [()]
_, Ty3
ty, (L3.TimeIt PreExp E3Ext () Ty3
rhs Ty3
_ Bool
flg)) PreExp E3Ext () Ty3
bod ->
        do Tail
rhs' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
rhs
           case Ty3
ty of
             ProdTy [Ty3]
ls ->
               do ([Var]
tmps,PreExp E3Ext () Ty3
bod') <- Var
-> [Ty3]
-> PreExp E3Ext () Ty3
-> PassM ([Var], PreExp E3Ext () Ty3)
eliminateProjs Var
vr [Ty3]
ls PreExp E3Ext () Ty3
bod
                  let bod'' :: PreExp E3Ext () Ty3
bod'' = [Var] -> [Var] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
updateAvailVars [Var
vr] [Var]
tmps PreExp E3Ext () Ty3
bod'
                  Bool -> [(Var, Ty)] -> Tail -> Tail -> Tail
T.LetTimedT Bool
flg ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
tmps ((Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ [Ty3]
ls)) Tail
rhs' (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod''
             Ty3
_ -> Bool -> [(Var, Ty)] -> Tail -> Tail -> Tail
T.LetTimedT Bool
flg   [(Var
vr, Ty3 -> Ty
typ Ty3
ty)]          Tail
rhs' (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod


    --------------------------------Start PrimApps----------------------------------
    -- (1) Primapps that become Tails:

    -- FIXME: No reason errors can't stay primitive at Target:
    PrimAppE (ErrorP [Char]
str Ty3
_ty) [] ->
      Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char] -> Tail
T.ErrT [Char]
str

    LetE (Var
_,[()]
_,Ty3
_, (PrimAppE (L3.ErrorP [Char]
str Ty3
_) [])) PreExp E3Ext () Ty3
_ ->
      Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char] -> Tail
T.ErrT [Char]
str

    -- Whatever... a little just-in-time flattening.  Should obsolete this:
    PrimAppE (DictEmptyP Ty3
ty) ((VarE Var
v):[PreExp E3Ext () Ty3]
ls) -> do
      Var
tmp <- 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
$ [Char] -> Var
toVar [Char]
"flt"
      Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl ((Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
tmp, [], Maybe Var -> Ty3 -> Ty3
forall loc. Maybe Var -> Ty3 -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v) Ty3
ty, Prim Ty3 -> [PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty3 -> Prim Ty3
forall ty. ty -> Prim ty
DictEmptyP Ty3
ty) ((Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)PreExp E3Ext () Ty3
-> [PreExp E3Ext () Ty3] -> [PreExp E3Ext () Ty3]
forall a. a -> [a] -> [a]
:[PreExp E3Ext () Ty3]
ls)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp))

    PrimAppE (DictInsertP Ty3
ty) ((VarE Var
v):[PreExp E3Ext () Ty3]
ls) -> do
      Var
tmp <- 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
$ [Char] -> Var
toVar [Char]
"flt"
      Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl ((Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
tmp, [], Maybe Var -> Ty3 -> Ty3
forall loc. Maybe Var -> Ty3 -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v) Ty3
ty, Prim Ty3 -> [PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty3 -> Prim Ty3
forall ty. ty -> Prim ty
DictInsertP Ty3
ty) ((Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)PreExp E3Ext () Ty3
-> [PreExp E3Ext () Ty3] -> [PreExp E3Ext () Ty3]
forall a. a -> [a] -> [a]
:[PreExp E3Ext () Ty3]
ls)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp))

    PrimAppE Prim Ty3
p [PreExp E3Ext () Ty3]
ls -> do
      Var
tmp <- 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
$ [Char] -> Var
toVar [Char]
"flt"
      Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl ((Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
tmp, [], Prim Ty3 -> Ty3
forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim Ty3
p, Prim Ty3 -> [PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty3
p [PreExp E3Ext () Ty3]
ls) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp))

    ---------------------
    -- (2) Next FAKE Primapps.  These could be added to L3 if we wanted to pollute it.

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (ReadScalar Scalar
s Var
cur))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpval"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpcur"

      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp)
                 PreExp E3Ext () Ty3
bod

      Int -> [Char] -> Tail -> Tail
forall a. Int -> [Char] -> a -> a
dbgTrace Int
7 ([Char]
" [lower] ReadInt, after substing references to "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Var -> [Char]
fromVar Var
v)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
bod') (Tail -> Tail) -> (Tail -> Tail) -> Tail -> Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp, Scalar -> Ty
T.scalarToTy Scalar
s),(Var
ctmp,Ty
T.CursorTy)] (Scalar -> Prim
T.ReadScalar Scalar
s) [Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'

    LetE (Var
v, [()]
_, Ty3
_,  (Ext (WriteScalar Scalar
s Var
c PreExp E3Ext () Ty3
e))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] (Scalar -> Prim
T.WriteScalar Scalar
s) [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteTag arg" PreExp E3Ext () Ty3
e, Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod


    -- In Target, AddP is overloaded still:
    LetE (Var
v,[()]
_, Ty3
_,  (Ext (AddCursor Var
c ( (Ext (MMapFileSize Var
w)))))) PreExp E3Ext () Ty3
bod -> do
      Var
size <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> Var -> Var
varAppend Var
"sizeof_" Var
v)
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
size,Ty
T.IntTy)] (Var -> Prim
T.MMapFileSize Var
w) [] (Tail -> Tail) -> (Tail -> Tail) -> Tail -> Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.AddP [ Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"addCursor base" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
c)
                                               , Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"addCursor offset" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
size)] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_, Ty3
_,  (Ext (AddCursor Var
c PreExp E3Ext () Ty3
e))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.AddP [ Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"addCursor base" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
c)
                                             , Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"addCursor offset" PreExp E3Ext () Ty3
e] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_, Ty3
_,  (Ext (SubPtr Var
a Var
b))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.IntTy)] Prim
T.SubP [ Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"subCursor base" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
a)
                                          , Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"subCursor offset" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
b)] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_, Ty3
_,  (Ext (ReadTag Var
cur))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmptag"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpcur"

      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp)
                 PreExp E3Ext () Ty3
bod

      Int -> [Char] -> Tail -> Tail
forall a. Int -> [Char] -> a -> a
dbgTrace Int
7 ([Char]
" [lower] ReadTag, after substing references to "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Var -> [Char]
fromVar Var
v)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
bod') (Tail -> Tail) -> (Tail -> Tail) -> Tail -> Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp,Ty
T.TagTyPacked),(Var
ctmp,Ty
T.CursorTy)] Prim
T.ReadTag [Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'
      -- error $ "lower: ReadTag not handled yet."


    LetE (Var
cursOut,[()]
_, Ty3
_,  (Ext (WriteTag [Char]
dcon Var
cursIn))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
cursOut,Ty
T.CursorTy)] Prim
T.WriteTag
        [ Tag -> Triv
T.TagTriv (Map Var (DDef Ty3) -> [Char] -> Tag
forall a. Out a => DDefs a -> [Char] -> Tag
getTagOfDataCon DDefs (TyOf (PreExp E3Ext () Ty3))
Map Var (DDef Ty3)
ddefs [Char]
dcon) , Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteTag cursor" (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
cursIn) ] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (NewBuffer Multiplicity
mul))) PreExp E3Ext () Ty3
bod -> do
      Var
reg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"region"
      Tail
tl' <- [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
reg,Ty
T.CursorTy),(Var
v,Ty
T.CursorTy),(Var -> Var
toEndV Var
v,Ty
T.CursorTy)] (Multiplicity -> Prim
T.NewBuffer Multiplicity
mul) [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DisableGC DynFlags
dflags -- -- || not free_reg
         then Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tail
tl'
         else
           -- The type shouldn't matter. PtrTy is not used often in current programs,
           -- and would be easy to spot.
           (Tail, Ty) -> ([Triv] -> Tail) -> PassM Tail
forall (m :: * -> *).
MonadState Int m =>
(Tail, Ty) -> ([Triv] -> Tail) -> m Tail
T.withTail (Tail
tl',Ty
T.PtrTy) (([Triv] -> Tail) -> PassM Tail) -> ([Triv] -> Tail) -> PassM Tail
forall a b. (a -> b) -> a -> b
$ \[Triv]
trvs ->
              ([(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.FreeBuffer [(Var -> Triv
T.VarTriv Var
reg),(Var -> Triv
T.VarTriv Var
v),(Var -> Triv
T.VarTriv (Var -> Var
toEndV Var
v))] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
                 [Triv] -> Tail
T.RetValsT [Triv]
trvs)

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (NewParBuffer Multiplicity
mul))) PreExp E3Ext () Ty3
bod -> do
      Var
reg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"region"
      Tail
tl' <- [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
reg,Ty
T.CursorTy),(Var
v,Ty
T.CursorTy),(Var -> Var
toEndV Var
v,Ty
T.CursorTy)] (Multiplicity -> Prim
T.NewParBuffer Multiplicity
mul) [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DisableGC DynFlags
dflags -- || not free_reg
         then Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tail
tl'
         else
           -- The type shouldn't matter. PtrTy is not used often in current programs,
           -- and would be easy to spot.
           (Tail, Ty) -> ([Triv] -> Tail) -> PassM Tail
forall (m :: * -> *).
MonadState Int m =>
(Tail, Ty) -> ([Triv] -> Tail) -> m Tail
T.withTail (Tail
tl',Ty
T.PtrTy) (([Triv] -> Tail) -> PassM Tail) -> ([Triv] -> Tail) -> PassM Tail
forall a b. (a -> b) -> a -> b
$ \[Triv]
trvs ->
              ([(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.FreeBuffer [(Var -> Triv
T.VarTriv Var
reg),(Var -> Triv
T.VarTriv Var
v),(Var -> Triv
T.VarTriv (Var -> Var
toEndV Var
v))] (Tail -> Tail) -> Tail -> Tail
forall a b. (a -> b) -> a -> b
$
                 [Triv] -> Tail
T.RetValsT [Triv]
trvs)

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (ScopedBuffer Multiplicity
mul))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] (Multiplicity -> Prim
T.ScopedBuffer Multiplicity
mul) [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (ScopedParBuffer Multiplicity
mul))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] (Multiplicity -> Prim
T.ScopedParBuffer Multiplicity
mul) [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (EndOfBuffer Multiplicity
mul))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] (Multiplicity -> Prim
T.EndOfBuffer Multiplicity
mul) [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (SizeOfPacked Var
start Var
end))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.IntTy)] Prim
T.SizeOfPacked [ Var -> Triv
T.VarTriv Var
start, Var -> Triv
T.VarTriv Var
end ] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v,[()]
_,Ty3
_,  (Ext (SizeOfScalar Var
w))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.IntTy)] Prim
T.SizeOfScalar [ Var -> Triv
T.VarTriv Var
w ] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    -- Just a side effect
    LetE(Var
_,[()]
_,Ty3
_,  (Ext (BoundsCheck Int
i Var
bound Var
cur))) PreExp E3Ext () Ty3
bod -> do
      let args :: [Triv]
args = [Int64 -> Triv
T.IntTriv (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i), Var -> Triv
T.VarTriv Var
bound, Var -> Triv
T.VarTriv Var
cur]
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.BoundsCheck [Triv]
args (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE(Var
v,[()]
_,Ty3
_,  (Ext (TagCursor Var
a Var
b))) PreExp E3Ext () Ty3
bod -> do
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v, Ty
T.CursorTy)] Prim
T.TagCursor [Var -> Triv
T.VarTriv Var
a, Var -> Triv
T.VarTriv Var
b] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE(Var
v,[()]
_,Ty3
_,  (Ext (ReadTaggedCursor Var
c))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpcur"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpaftercur"
      Var
tagtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmptag"
      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
2 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tagtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
bod
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp,Ty
T.CursorTy),(Var
ctmp,Ty
T.CursorTy),(Var
tagtmp,Ty
T.IntTy)] Prim
T.ReadTaggedCursor [Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'

    LetE (Var
v, [()]
_, Ty3
_,  (Ext (WriteTaggedCursor Var
cur PreExp E3Ext () Ty3
e))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.WriteTaggedCursor [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteTaggedCursor arg" PreExp E3Ext () Ty3
e, Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE(Var
v,[()]
_,Ty3
_,  (Ext (ReadCursor Var
c))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpcur"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpaftercur"
      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp)
                 PreExp E3Ext () Ty3
bod
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp,Ty
T.CursorTy),(Var
ctmp,Ty
T.CursorTy)] Prim
T.ReadCursor [Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'

    LetE(Var
v,[()]
_,Ty3
_,  (Ext (ReadList Var
c Ty3
el_ty))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmplist"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpafterlist"
      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp)
                 PreExp E3Ext () Ty3
bod
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp,Ty -> Ty
T.ListTy (Ty3 -> Ty
T.fromL3Ty Ty3
el_ty)),(Var
ctmp,Ty
T.CursorTy)] Prim
T.ReadList [Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'

    LetE (Var
v, [()]
_, Ty3
_,  (Ext (WriteList Var
cur PreExp E3Ext () Ty3
e Ty3
_el_ty))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.WriteList [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteList arg" PreExp E3Ext () Ty3
e, Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod


    LetE(Var
v,[()]
_,Ty3
_,  (Ext (ReadVector Var
c Ty3
el_ty))) PreExp E3Ext () Ty3
bod -> do
      Var
vtmp <- 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
$ [Char] -> Var
toVar [Char]
"tmplist"
      Var
ctmp <- 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
$ [Char] -> Var
toVar [Char]
"tmpafterlist"
      -- Here we lamely chase down all the tuple references and make them variables:
      let bod' :: PreExp E3Ext () Ty3
bod' = PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
0 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vtmp) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                 PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
1 (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ctmp)
                 PreExp E3Ext () Ty3
bod
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
vtmp,Ty -> Ty
T.VectorTy (Ty3 -> Ty
T.fromL3Ty Ty3
el_ty)),(Var
ctmp,Ty
T.CursorTy)] Prim
T.ReadVector [Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod'

    LetE (Var
v, [()]
_, Ty3
_,  (Ext (WriteVector Var
cur PreExp E3Ext () Ty3
e Ty3
_el_ty))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.WriteVector [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteVector arg" PreExp E3Ext () Ty3
e, Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v, [()]
_, Ty3
_,  (Ext (WriteCursor Var
cur PreExp E3Ext () Ty3
e))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty
T.CursorTy)] Prim
T.WriteCursor [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"WriteCursor arg" PreExp E3Ext () Ty3
e, Var -> Triv
T.VarTriv Var
cur] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
_, [()]
_, Ty3
_,  (Ext (IndirectionBarrier [Char]
tycon (Var
l1, Var
end_r1, Var
l2, Var
end_r2)))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] ([Char] -> Prim
T.IndirectionBarrier [Char]
tycon) [Var -> Triv
T.VarTriv Var
l1, Var -> Triv
T.VarTriv Var
end_r1, Var -> Triv
T.VarTriv Var
l2, Var -> Triv
T.VarTriv Var
end_r2] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
_, [()]
_, Ty3
_,  (Ext (BumpArenaRefCount Var
ar Var
end_r))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.BumpArenaRefCount [Var -> Triv
T.VarTriv Var
ar, Var -> Triv
T.VarTriv Var
end_r] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v, [()]
_, Ty3
_,  (Ext E3Ext () Ty3
NullCursor)) PreExp E3Ext () Ty3
bod ->
      (Var, Ty, Triv) -> Tail -> Tail
T.LetTrivT (Var
v,Ty
T.CursorTy,Int64 -> Triv
T.IntTriv Int64
0) (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
v, [()]
_, Ty3
ty, (Ext E3Ext () Ty3
GetCilkWorkerNum)) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty3 -> Ty
typ Ty3
ty)] Prim
T.GetCilkWorkerNum [] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
_v, [()]
_, Ty3
_ty, (Ext (SSPush SSModality
a Var
b Var
c [Char]
d))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] (SSModality -> [Char] -> Prim
T.SSPush SSModality
a [Char]
d) [Var -> Triv
T.VarTriv Var
b, Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
_v, [()]
_, Ty3
_ty, (Ext (SSPop SSModality
a Var
b Var
c))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] (SSModality -> Prim
T.SSPop SSModality
a) [Var -> Triv
T.VarTriv Var
b, Var -> Triv
T.VarTriv Var
c] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    LetE (Var
_v, [()]
_, Ty3
_ty, (Ext (Assert PreExp E3Ext () Ty3
a))) PreExp E3Ext () Ty3
bod ->
      [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.Assert [Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"Assert arg" PreExp E3Ext () Ty3
a] (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod


    LetE (Var
_v, [()]
_, Ty3
_ty, rhs :: PreExp E3Ext () Ty3
rhs@(Ext AllocateTagHere{})) PreExp E3Ext () Ty3
_bod -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
rhs
    LetE (Var
_v, [()]
_, Ty3
_ty, rhs :: PreExp E3Ext () Ty3
rhs@(Ext AllocateScalarsHere{})) PreExp E3Ext () Ty3
_bod -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
rhs
    LetE (Var
_v, [()]
_, Ty3
_ty, rhs :: PreExp E3Ext () Ty3
rhs@(Ext StartTagAllocation{})) PreExp E3Ext () Ty3
_bod -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
rhs
    LetE (Var
_v, [()]
_, Ty3
_ty, rhs :: PreExp E3Ext () Ty3
rhs@(Ext StartScalarsAllocation{})) PreExp E3Ext () Ty3
_bod -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
rhs
    -- [2023.04.19]: be forgiving about an earlier pass not removing these.
    LetE (Var
_v, [()]
_, Ty3
_ty, (Ext EndTagAllocation{})) PreExp E3Ext () Ty3
bod -> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
    LetE (Var
_v, [()]
_, Ty3
_ty, (Ext EndScalarsAllocation{})) PreExp E3Ext () Ty3
bod -> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    Ext (LetAvail [Var]
vs PreExp E3Ext () Ty3
bod) ->
      [Var] -> Tail -> Tail
T.LetAvailT [Var]
vs (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod

    Ext E3Ext () Ty3
_ -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: unexpected extension" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
ex0

    ---------------------
    -- (3) Proper primapps.
    LetE (Var
v,[()]
_,Ty3
t,  (PrimAppE Prim Ty3
p [PreExp E3Ext () Ty3]
ls)) PreExp E3Ext () Ty3
bod -> Int -> [Char] -> PassM Tail -> PassM Tail
forall a. Int -> [Char] -> a -> a
dbgTrace Int
7 ([Char]
"lower: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
forall a. Show a => a -> [Char]
show Var
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty3 -> [Char]
forall a. Show a => a -> [Char]
show Ty3
t) (PassM Tail -> PassM Tail) -> PassM Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$
        -- No tuple-valued prims here:
        [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [(Var
v,Ty3 -> Ty
typ Ty3
t)]
             (Prim Ty3 -> Prim
prim Prim Ty3
p)
             ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
L.map (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl ([Char] -> PreExp E3Ext () Ty3 -> Triv)
-> [Char] -> PreExp E3Ext () Ty3 -> Triv
forall a b. (a -> b) -> a -> b
$ [Char]
"prim rand "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Prim Ty3 -> [Char]
forall a. Show a => a -> [Char]
show Prim Ty3
p) [PreExp E3Ext () Ty3]
ls) (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             (Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod)
    --------------------------------End PrimApps----------------------------------

    AppE Var
v [()]
_ [PreExp E3Ext () Ty3]
ls -> Tail -> PassM Tail
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ Var -> [Triv] -> Tail
T.TailCall Var
v ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
map (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"operand") [PreExp E3Ext () Ty3]
ls)

    SpawnE{} -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error [Char]
"lower: Unbound SpanwnE"
    PreExp E3Ext () Ty3
SyncE    -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error [Char]
"lower: Unbound SpanwnE"

    -- Tail calls are just an optimization, if we have a Proj/App it cannot be tail:
    ProjE Int
ix ( (AppE Var
f [()]
_ [PreExp E3Ext () Ty3]
e)) -> Int -> [Char] -> PassM Tail -> PassM Tail
forall a. Int -> [Char] -> a -> a
dbgTrace Int
5 [Char]
"ProjE" (PassM Tail -> PassM Tail) -> PassM Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ do
        Var
tmp <- 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
$ [Char] -> Var
toVar [Char]
"prjapp"
        let ([Ty3]
inTs, Ty3
_) = FunDef (PreExp E3Ext () Ty3)
-> ArrowTy (TyOf (PreExp E3Ext () Ty3))
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy (FunDefs (PreExp E3Ext () Ty3)
fundefs FunDefs (PreExp E3Ext () Ty3)
-> Var -> FunDef (PreExp E3Ext () Ty3)
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
f)
        Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl (PreExp E3Ext () Ty3 -> PassM Tail)
-> PreExp E3Ext () Ty3 -> PassM Tail
forall a b. (a -> b) -> a -> b
$
          (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE ( Var
tmp
                  , []
                  , (() -> ()) -> Ty3 -> Ty3
forall a b. (a -> b) -> UrTy a -> UrTy b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> () -> ()
forall a b. a -> b -> a
const ()) ([Ty3]
inTs [Ty3] -> Int -> Ty3
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix)
                  , Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix (Var -> [()] -> [PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [PreExp E3Ext () Ty3]
e))
             (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp)

    LetE (Var
_,[()]
_,Ty3
_, ( (L3.AppE Var
f [()]
_ [PreExp E3Ext () Ty3]
_))) PreExp E3Ext () Ty3
_
        | Var -> FunDefs (PreExp E3Ext () Ty3) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Var
f FunDefs (PreExp E3Ext () Ty3)
fundefs -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"Application of unbound function: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Var -> [Char]
forall a. Show a => a -> [Char]
show Var
f

    -- Non-tail free_reg call:
    LetE (Var
vr, [()]
_,Ty3
t, PreExp E3Ext () Ty3 -> ([Int], PreExp E3Ext () Ty3)
projOf -> ([Int]
stk, ( (L3.AppE Var
f [()]
_ [PreExp E3Ext () Ty3]
ls)))) PreExp E3Ext () Ty3
bod -> do
        let ([Ty3]
_ , Ty3
outTy) = FunDef (PreExp E3Ext () Ty3)
-> ArrowTy (TyOf (PreExp E3Ext () Ty3))
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy (FunDefs (PreExp E3Ext () Ty3)
fundefs FunDefs (PreExp E3Ext () Ty3)
-> Var -> FunDef (PreExp E3Ext () Ty3)
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
f)
        let f' :: Var
f' = Var -> Var
cleanFunName Var
f
        ([(Var, Ty)]
vsts,PreExp E3Ext () Ty3
bod') <- case Ty3
outTy of
                        L3.ProdTy [] -> ([(Var, Ty)], PreExp E3Ext () Ty3)
-> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var
vr,Ty3 -> Ty
typ Ty3
t)], PreExp E3Ext () Ty3
bod)
                        L3.ProdTy [Ty3]
tys ->
                          case [Int]
stk of
                            [] -> do ([Var]
tmps,PreExp E3Ext () Ty3
e) <- Var
-> [Ty3]
-> PreExp E3Ext () Ty3
-> PassM ([Var], PreExp E3Ext () Ty3)
eliminateProjs Var
vr ((Ty3 -> Ty3) -> [Ty3] -> [Ty3]
forall a b. (a -> b) -> [a] -> [b]
L.map ((() -> ()) -> Ty3 -> Ty3
forall a b. (a -> b) -> UrTy a -> UrTy b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> () -> ()
forall a b. a -> b -> a
const ())) [Ty3]
tys) PreExp E3Ext () Ty3
bod
                                     let e' :: PreExp E3Ext () Ty3
e' = [Var] -> [Var] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
updateAvailVars [Var
vr] [Var]
tmps PreExp E3Ext () Ty3
e
                                     ([(Var, Ty)], PreExp E3Ext () Ty3)
-> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
tmps ((Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ [Ty3]
tys), PreExp E3Ext () Ty3
e')
                            -- More than one should not currently be
                            -- possible (no nested tuple returns):
                            [Int
ix] -> do [Var]
garbages <- [PassM Var] -> PassM [Var]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"garbage" | Ty3
_ <- [Ty3] -> [Ty3]
forall a. HasCallStack => [a] -> [a]
L.tail [Ty3]
tys ]
                                       let ([Var]
lead,[Var]
trail) = Int -> [Var] -> ([Var], [Var])
forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
ix [Var]
garbages
                                       ([(Var, Ty)], PreExp E3Ext () Ty3)
-> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Var]
lead[Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++[Var
vr][Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++[Var]
trail)
                                                    ((Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ [Ty3]
tys)
                                              , PreExp E3Ext () Ty3
bod)
                            [Int]
oth -> [Char] -> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM ([(Var, Ty)], PreExp E3Ext () Ty3))
-> [Char] -> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a b. (a -> b) -> a -> b
$ [Char]
"lower.tail.LetE: unexpected pattern" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
oth
                        Ty3
_ -> ([(Var, Ty)], PreExp E3Ext () Ty3)
-> PassM ([(Var, Ty)], PreExp E3Ext () Ty3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var
vr,Ty3 -> Ty
typ Ty3
t)], PreExp E3Ext () Ty3
bod)
        Bool -> [(Var, Ty)] -> Var -> [Triv] -> Tail -> Tail
T.LetCallT Bool
False [(Var, Ty)]
vsts Var
f' ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
L.map (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"one of app rands") [PreExp E3Ext () Ty3]
ls) (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod')

    LetE (Var
v, [()]
_,Ty3
ty, L3.SpawnE Var
fn [()]
locs [PreExp E3Ext () Ty3]
args) PreExp E3Ext () Ty3
bod -> do
      T.LetCallT{Bool
[(Var, Ty)]
[Triv]
Var
Tail
async :: Bool
binds :: [(Var, Ty)]
rator :: Var
rands :: [Triv]
bod :: Tail
async :: Tail -> Bool
binds :: Tail -> [(Var, Ty)]
rator :: Tail -> Var
rands :: Tail -> [Triv]
bod :: Tail -> Tail
..} <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl ((Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[()]
_,Ty3
ty, Var -> [()] -> [PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fn [()]
locs [PreExp E3Ext () Ty3]
args) PreExp E3Ext () Ty3
bod)
      Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ T.LetCallT  { async :: Bool
T.async = Bool
True, [(Var, Ty)]
[Triv]
Var
Tail
binds :: [(Var, Ty)]
rator :: Var
rands :: [Triv]
bod :: Tail
binds :: [(Var, Ty)]
rator :: Var
rands :: [Triv]
bod :: Tail
.. }

    LetE (Var
_,[()]
_,Ty3
_,  PreExp E3Ext () Ty3
SyncE) PreExp E3Ext () Ty3
bod -> do
      Tail
bod' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod
      Tail -> PassM Tail
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tail -> PassM Tail) -> Tail -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [(Var, Ty)] -> Prim -> [Triv] -> Tail -> Tail
T.LetPrimCallT [] Prim
T.ParSync [] Tail
bod'

    LetE (Var
v, [()]
_, Ty3
t,  (IfE PreExp E3Ext () Ty3
a PreExp E3Ext () Ty3
b PreExp E3Ext () Ty3
c)) PreExp E3Ext () Ty3
bod -> do
      let a' :: Triv
a' = Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"if test" PreExp E3Ext () Ty3
a
      Tail
b' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
b
      Tail
c' <- Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
c
      case Ty3
t of
        -- Finilize unarisation:
        ProdTy [Ty3]
ls -> do
             ([Var]
tmps,PreExp E3Ext () Ty3
bod') <- Var
-> [Ty3]
-> PreExp E3Ext () Ty3
-> PassM ([Var], PreExp E3Ext () Ty3)
eliminateProjs Var
v [Ty3]
ls PreExp E3Ext () Ty3
bod
             let bod'' :: PreExp E3Ext () Ty3
bod'' = [Var] -> [Var] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
updateAvailVars [Var
v] [Var]
tmps PreExp E3Ext () Ty3
bod'
             [(Var, Ty)] -> (Triv, Tail, Tail) -> Tail -> Tail
T.LetIfT ([Var] -> [Ty] -> [(Var, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
tmps ((Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ [Ty3]
ls)) (Triv
a', Tail
b', Tail
c') (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod''
        Ty3
_ -> [(Var, Ty)] -> (Triv, Tail, Tail) -> Tail -> Tail
T.LetIfT [(Var
v, Ty3 -> Ty
typ Ty3
t)] (Triv
a', Tail
b', Tail
c') (Tail -> Tail) -> PassM Tail -> PassM Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Map [Char] Word16 -> PreExp E3Ext () Ty3 -> PassM Tail
tail Bool
free_reg Map [Char] Word16
sym_tbl PreExp E3Ext () Ty3
bod


    PreExp E3Ext () Ty3
_ -> [Char] -> PassM Tail
forall a. HasCallStack => [Char] -> a
error([Char] -> PassM Tail) -> [Char] -> PassM Tail
forall a b. (a -> b) -> a -> b
$ [Char]
"lower: unexpected expression in tail position:\n  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
ex0


-- Helpers
--------------------------------------------------------------------------------

-- | View pattern for matching agaist projections of Foo rather than just Foo.
projOf :: Exp3 -> ([Int], Exp3)
projOf :: PreExp E3Ext () Ty3 -> ([Int], PreExp E3Ext () Ty3)
projOf ( (ProjE Int
ix PreExp E3Ext () Ty3
e)) = let ([Int]
stk,PreExp E3Ext () Ty3
e') = PreExp E3Ext () Ty3 -> ([Int], PreExp E3Ext () Ty3)
projOf PreExp E3Ext () Ty3
e
                           in ([Int]
stk[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int
ix], PreExp E3Ext () Ty3
e')
projOf PreExp E3Ext () Ty3
e = ([],PreExp E3Ext () Ty3
e)



-- | Eliminate projections from a given tuple variable.  INEFFICIENT!
eliminateProjs :: Var -> [Ty3] -> Exp3 -> PassM ([Var],Exp3)
eliminateProjs :: Var
-> [Ty3]
-> PreExp E3Ext () Ty3
-> PassM ([Var], PreExp E3Ext () Ty3)
eliminateProjs Var
vr [Ty3]
tys PreExp E3Ext () Ty3
bod =
 Int
-> [Char]
-> PassM ([Var], PreExp E3Ext () Ty3)
-> PassM ([Var], PreExp E3Ext () Ty3)
forall a. Int -> [Char] -> a -> a
dbgTrace Int
7 ([Char]
" [lower] eliminating "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show ([Ty3] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ty3]
tys)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
             [Char]
" projections on variable "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Var -> [Char]
forall a. Show a => a -> [Char]
show Var
vr[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" in expr with types "
                                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Ty3] -> [Char]
forall a. Show a => a -> [Char]
show [Ty3]
tys[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n   "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
bod) (PassM ([Var], PreExp E3Ext () Ty3)
 -> PassM ([Var], PreExp E3Ext () Ty3))
-> PassM ([Var], PreExp E3Ext () Ty3)
-> PassM ([Var], PreExp E3Ext () Ty3)
forall a b. (a -> b) -> a -> b
$
 do [Var]
tmps <- (Int -> PassM Var) -> [Int] -> 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 (\Int
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"pvrtmp") [Int
1.. ([Ty3] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ty3]
tys)]
    let go :: Int -> [(Var, Ty3)] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
go Int
_ [] PreExp E3Ext () Ty3
acc =
            -- If there are ANY references left, we are forced to make the products:
            Var
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.subst Var
vr ([PreExp E3Ext () Ty3] -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ((Var -> PreExp E3Ext () Ty3) -> [Var] -> [PreExp E3Ext () Ty3]
forall a b. (a -> b) -> [a] -> [b]
L.map Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
tmps)) PreExp E3Ext () Ty3
acc
        go Int
ix ((Var
pvr,Ty3
_pty):[(Var, Ty3)]
rs) PreExp E3Ext () Ty3
acc =
           Int -> [(Var, Ty3)] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
go (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(Var, Ty3)]
rs
             (PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
-> PreExp E3Ext () Ty3
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
L3.substE (Int -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vr)) (Var -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
pvr) PreExp E3Ext () Ty3
acc)
    let bod' :: PreExp E3Ext () Ty3
bod' = Int -> [(Var, Ty3)] -> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
go Int
0 ([Var] -> [Ty3] -> [(Var, Ty3)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
tmps [Ty3]
tys) PreExp E3Ext () Ty3
bod
    ([Var], PreExp E3Ext () Ty3) -> PassM ([Var], PreExp E3Ext () Ty3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
tmps,PreExp E3Ext () Ty3
bod')



mkLet :: (Var, Ty3, Exp3) -> Exp3 -> Exp3
mkLet :: (Var, Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
mkLet (Var
v,Ty3
t,  (LetE (Var
v2, [()]
_,Ty3
t2,PreExp E3Ext () Ty3
rhs2) PreExp E3Ext () Ty3
bod1)) PreExp E3Ext () Ty3
bod2 = (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v2,[],Ty3
t2,PreExp E3Ext () Ty3
rhs2) (PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall a b. (a -> b) -> a -> b
$
                                                    (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty3
t,PreExp E3Ext () Ty3
bod1) PreExp E3Ext () Ty3
bod2
mkLet (Var
v,Ty3
t,PreExp E3Ext () Ty3
rhs) PreExp E3Ext () Ty3
bod = (Var, [()], Ty3, PreExp E3Ext () Ty3)
-> PreExp E3Ext () Ty3 -> PreExp E3Ext () Ty3
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty3
t,PreExp E3Ext () Ty3
rhs) PreExp E3Ext () Ty3
bod



triv :: M.Map String Word16 -> String -> Exp3 -> T.Triv
triv :: Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
msg ( PreExp E3Ext () Ty3
e0) =
  case PreExp E3Ext () Ty3
e0 of
    (VarE Var
x) -> Var -> Triv
T.VarTriv Var
x
    (LitE Int
x) -> Int64 -> Triv
T.IntTriv (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)      -- TODO: back propogate Int64 to L1
    (CharE Char
c) -> Char -> Triv
T.CharTriv Char
c
    (FloatE Double
x)  -> Double -> Triv
T.FloatTriv Double
x -- TODO: back propogate Int64 to L1
    (LitSymE Var
v) -> let s :: [Char]
s = Var -> [Char]
fromVar Var
v in
                   case [Char] -> Map [Char] Word16 -> Maybe Word16
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
s Map [Char] Word16
sym_tbl of
                     Just Word16
i  -> Word16 -> Triv
T.SymTriv Word16
i
                     -- Impossible case, b/c we collect all the symbols in the
                     -- program in the very first step.
                     Maybe Word16
Nothing -> [Char] -> Triv
forall a. HasCallStack => [Char] -> a
error ([Char] -> Triv) -> [Char] -> Triv
forall a b. (a -> b) -> a -> b
$ [Char]
"triv: Symbol not found in table: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Out a => a -> [Char]
sdoc [Char]
s
    -- Bools become ints:
    (PrimAppE Prim Ty3
L3.MkTrue [])  -> Bool -> Triv
T.BoolTriv Bool
True
    (PrimAppE Prim Ty3
L3.MkFalse []) -> Bool -> Triv
T.BoolTriv Bool
False
    -- Heck, let's map Unit onto Int too:
    (MkProdE []) -> Int64 -> Triv
T.IntTriv Int64
0
    (MkProdE [PreExp E3Ext () Ty3]
ls) -> [Triv] -> Triv
T.ProdTriv ((PreExp E3Ext () Ty3 -> Triv) -> [PreExp E3Ext () Ty3] -> [Triv]
forall a b. (a -> b) -> [a] -> [b]
map (\PreExp E3Ext () Ty3
x -> Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl (PreExp E3Ext () Ty3 -> [Char]
forall a. Show a => a -> [Char]
show PreExp E3Ext () Ty3
x) PreExp E3Ext () Ty3
x) [PreExp E3Ext () Ty3]
ls)
    (ProjE Int
ix PreExp E3Ext () Ty3
e) -> Int -> Triv -> Triv
T.ProjTriv Int
ix (Map [Char] Word16 -> [Char] -> PreExp E3Ext () Ty3 -> Triv
triv Map [Char] Word16
sym_tbl [Char]
"proje argument" PreExp E3Ext () Ty3
e)
    PreExp E3Ext () Ty3
_ | PreExp E3Ext () Ty3 -> Bool
forall e. Expression e => e -> Bool
isTrivial PreExp E3Ext () Ty3
e0 -> [Char] -> Triv
forall a. HasCallStack => [Char] -> a
error ([Char] -> Triv) -> [Char] -> Triv
forall a b. (a -> b) -> a -> b
$ [Char]
"lower/triv: this function is written wrong.  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                         [Char]
"It won't handle the following, which satisfies 'isTriv':\n "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
e0[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                         [Char]
"\nMessage: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg
    PreExp E3Ext () Ty3
_ -> [Char] -> Triv
forall a. HasCallStack => [Char] -> a
error ([Char] -> Triv) -> [Char] -> Triv
forall a b. (a -> b) -> a -> b
$ [Char]
"lower/triv, expected trivial in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
", got "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PreExp E3Ext () Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc PreExp E3Ext () Ty3
e0

typ :: UrTy () -> T.Ty
typ :: Ty3 -> Ty
typ Ty3
t =
  case Ty3
t of
    Ty3
IntTy  -> Ty
T.IntTy
    Ty3
CharTy -> Ty
T.CharTy
    Ty3
FloatTy-> Ty
T.FloatTy
    Ty3
SymTy  -> Ty
T.SymTy
    Ty3
BoolTy -> Ty
T.BoolTy
    VectorTy Ty3
el_ty -> Ty -> Ty
T.VectorTy (Ty3 -> Ty
typ Ty3
el_ty)
    ListTy Ty3
el_ty -> Ty -> Ty
T.ListTy (Ty3 -> Ty
typ Ty3
el_ty)
    PDictTy Ty3
k Ty3
v -> Ty -> Ty -> Ty
T.PDictTy (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    ProdTy [Ty3]
xs -> [Ty] -> Ty
T.ProdTy ([Ty] -> Ty) -> [Ty] -> Ty
forall a b. (a -> b) -> a -> b
$ (Ty3 -> Ty) -> [Ty3] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
L.map Ty3 -> Ty
typ [Ty3]
xs
    SymDictTy (Just Var
var) Ty3
x -> Var -> Ty -> Ty
T.SymDictTy Var
var (Ty -> Ty) -> Ty -> Ty
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
x
    SymDictTy Maybe Var
Nothing Ty3
_ty -> [Char] -> Ty
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ty) -> [Char] -> Ty
forall a b. (a -> b) -> a -> b
$ [Char]
"lower/typ: Expected arena annotation on type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty3
t)
    -- t | isCursorTy t -> T.CursorTy
    PackedTy{} -> Ty
T.CursorTy
    Ty3
CursorTy -> Ty
T.CursorTy -- Audit me
    Ty3
PtrTy -> Ty
T.PtrTy
    Ty3
ArenaTy   -> Ty
T.ArenaTy
    Ty3
SymSetTy  -> Ty
T.SymSetTy
    Ty3
SymHashTy -> Ty
T.SymHashTy
    Ty3
IntHashTy -> Ty
T.IntHashTy

typ' :: String -> Ty3 -> T.Ty
typ' :: [Char] -> Ty3 -> Ty
typ' [Char]
str Ty3
t = [Char] -> Ty -> Ty
forall a. [Char] -> a -> a
dbgTraceIt [Char]
str (Ty -> Ty) -> Ty -> Ty
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
t

prim :: Prim Ty3 -> T.Prim
prim :: Prim Ty3 -> Prim
prim Prim Ty3
p =
  case Prim Ty3
p of
    Prim Ty3
AddP -> Prim
T.AddP
    Prim Ty3
SubP -> Prim
T.SubP
    Prim Ty3
MulP -> Prim
T.MulP
    Prim Ty3
DivP -> Prim
T.DivP
    Prim Ty3
ModP -> Prim
T.ModP
    Prim Ty3
ExpP -> Prim
T.ExpP
    Prim Ty3
FAddP -> Prim
T.AddP
    Prim Ty3
FSubP -> Prim
T.SubP
    Prim Ty3
FMulP -> Prim
T.MulP
    Prim Ty3
FDivP -> Prim
T.DivP
    Prim Ty3
FExpP -> Prim
T.ExpP
    Prim Ty3
FRandP-> Prim
T.FRandP
    Prim Ty3
FSqrtP-> Prim
T.FSqrtP
    Prim Ty3
FTanP-> Prim
T.FTanP
    Prim Ty3
FloatToIntP -> Prim
T.FloatToIntP
    Prim Ty3
IntToFloatP -> Prim
T.IntToFloatP
    Prim Ty3
RandP -> Prim
T.RandP
    Prim Ty3
Gensym -> Prim
T.Gensym
    Prim Ty3
EqSymP -> Prim
T.EqSymP
    EqBenchProgP [Char]
str -> [Char] -> Prim
T.EqBenchProgP [Char]
str
    Prim Ty3
EqIntP -> Prim
T.EqP
    Prim Ty3
EqFloatP -> Prim
T.EqP
    Prim Ty3
EqCharP  -> Prim
T.EqP
    Prim Ty3
LtP    -> Prim
T.LtP
    Prim Ty3
GtP    -> Prim
T.GtP
    Prim Ty3
LtEqP  -> Prim
T.LtEqP
    Prim Ty3
GtEqP  -> Prim
T.GtEqP
    Prim Ty3
FLtP   -> Prim
T.LtP
    Prim Ty3
FGtP   -> Prim
T.GtP
    Prim Ty3
FLtEqP -> Prim
T.LtEqP
    Prim Ty3
FGtEqP -> Prim
T.GtEqP
    Prim Ty3
OrP    -> Prim
T.OrP
    Prim Ty3
AndP   -> Prim
T.AndP
    Prim Ty3
SizeParam -> Prim
T.SizeParam
    Prim Ty3
IsBig    -> Prim
T.IsBig
    Prim Ty3
PrintInt -> Prim
T.PrintInt
    Prim Ty3
PrintChar -> Prim
T.PrintChar
    Prim Ty3
PrintFloat -> Prim
T.PrintFloat
    Prim Ty3
PrintBool -> Prim
T.PrintBool
    Prim Ty3
PrintSym -> Prim
T.PrintSym
    Prim Ty3
ReadInt  -> Prim
T.ReadInt
    DictInsertP Ty3
ty -> Ty -> Prim
T.DictInsertP (Ty -> Prim) -> Ty -> Prim
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
ty
    DictLookupP Ty3
ty -> Ty -> Prim
T.DictLookupP (Ty -> Prim) -> Ty -> Prim
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
ty
    DictEmptyP Ty3
ty  -> Ty -> Prim
T.DictEmptyP (Ty -> Prim) -> Ty -> Prim
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
ty
    DictHasKeyP Ty3
ty -> Ty -> Prim
T.DictHasKeyP (Ty -> Prim) -> Ty -> Prim
forall a b. (a -> b) -> a -> b
$ Ty3 -> Ty
typ Ty3
ty
    ReadPackedFile Maybe [Char]
mf [Char]
tyc Maybe Var
_ Ty3
_ -> Maybe [Char] -> [Char] -> Prim
T.ReadPackedFile Maybe [Char]
mf [Char]
tyc
    WritePackedFile [Char]
fp Ty3
ty
      | (PackedTy [Char]
tycon ()
_) <- Ty3
ty -> [Char] -> [Char] -> Prim
T.WritePackedFile [Char]
fp [Char]
tycon
      | Bool
otherwise -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error ([Char] -> Prim) -> [Char] -> Prim
forall a b. (a -> b) -> a -> b
$ [Char]
"prim: writePackedFile given a non-packed type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty3 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty3
ty
    ReadArrayFile Maybe ([Char], Int)
fp Ty3
ty -> Maybe ([Char], Int) -> Ty -> Prim
T.ReadArrayFile Maybe ([Char], Int)
fp (Ty3 -> Ty
typ Ty3
ty)
    VAllocP Ty3
elty  -> Ty -> Prim
T.VAllocP (Ty3 -> Ty
typ Ty3
elty)
    VFreeP Ty3
elty   -> Ty -> Prim
T.VFreeP (Ty3 -> Ty
typ Ty3
elty)
    VFree2P Ty3
elty  -> Ty -> Prim
T.VFree2P (Ty3 -> Ty
typ Ty3
elty)
    VLengthP Ty3
elty -> Ty -> Prim
T.VLengthP (Ty3 -> Ty
typ Ty3
elty)
    VNthP Ty3
elty    -> Ty -> Prim
T.VNthP (Ty3 -> Ty
typ Ty3
elty)
    VSliceP Ty3
elty    -> Ty -> Prim
T.VSliceP (Ty3 -> Ty
typ Ty3
elty)
    InplaceVUpdateP Ty3
elty -> Ty -> Prim
T.InplaceVUpdateP (Ty3 -> Ty
typ Ty3
elty)
    VConcatP Ty3
elty -> Ty -> Prim
T.VConcatP (Ty3 -> Ty
typ Ty3
elty)
    VMergeP Ty3
elty  -> Ty -> Prim
T.VMergeP (Ty3 -> Ty
typ Ty3
elty)
    VSortP Ty3
elty   -> Ty -> Prim
T.VSortP (Ty3 -> Ty
typ Ty3
elty)
    InplaceVSortP Ty3
elty -> Ty -> Prim
T.InplaceVSortP (Ty3 -> Ty
typ Ty3
elty)
    PDictAllocP  Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictAllocP  (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    PDictInsertP Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictInsertP (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    PDictLookupP Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictLookupP (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    PDictHasKeyP Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictHasKeyP (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    PDictForkP Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictForkP (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    PDictJoinP Ty3
k Ty3
v -> Ty -> Ty -> Prim
T.PDictJoinP (Ty3 -> Ty
typ Ty3
k) (Ty3 -> Ty
typ Ty3
v)
    LLAllocP Ty3
elty -> Ty -> Prim
T.LLAllocP (Ty3 -> Ty
typ Ty3
elty)
    LLIsEmptyP Ty3
elty -> Ty -> Prim
T.LLIsEmptyP (Ty3 -> Ty
typ Ty3
elty)
    LLConsP Ty3
elty -> Ty -> Prim
T.LLConsP (Ty3 -> Ty
typ Ty3
elty)
    LLHeadP Ty3
elty -> Ty -> Prim
T.LLHeadP (Ty3 -> Ty
typ Ty3
elty)
    LLTailP Ty3
elty -> Ty -> Prim
T.LLTailP (Ty3 -> Ty
typ Ty3
elty)
    LLFreeP Ty3
elty -> Ty -> Prim
T.LLFreeP (Ty3 -> Ty
typ Ty3
elty)
    LLFree2P Ty3
elty -> Ty -> Prim
T.LLFree2P (Ty3 -> Ty
typ Ty3
elty)
    LLCopyP Ty3
elty -> Ty -> Prim
T.LLCopyP (Ty3 -> Ty
typ Ty3
elty)
    Prim Ty3
GetNumProcessors -> Prim
T.GetNumProcessors
    Prim Ty3
SymSetEmpty   -> Prim
T.SymSetEmpty
    Prim Ty3
SymSetInsert  -> Prim
T.SymSetInsert
    Prim Ty3
SymSetContains-> Prim
T.SymSetContains
    Prim Ty3
SymHashEmpty  -> Prim
T.SymHashEmpty
    Prim Ty3
SymHashInsert  -> Prim
T.SymHashInsert
    Prim Ty3
SymHashLookup  -> Prim
T.SymHashLookup
    Prim Ty3
SymHashContains  -> Prim
T.SymHashContains
    Prim Ty3
IntHashEmpty  -> Prim
T.IntHashEmpty
    Prim Ty3
IntHashInsert  -> Prim
T.IntHashInsert
    Prim Ty3
IntHashLookup  -> Prim
T.IntHashLookup
    Write3dPpmFile{} -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error([Char] -> Prim) -> [Char] -> Prim
forall a b. (a -> b) -> a -> b
$ [Char]
"lower/prim: internal error, Write3dPpmFile not handled yet."

    ErrorP{}     -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error([Char] -> Prim) -> [Char] -> Prim
forall a b. (a -> b) -> a -> b
$ [Char]
"lower/prim: internal error, should not have got to here: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Prim Ty3 -> [Char]
forall a. Show a => a -> [Char]
show Prim Ty3
p
    Prim Ty3
MkTrue       -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error [Char]
"lower/prim: internal error. MkTrue should not get here."
    Prim Ty3
MkFalse      -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error [Char]
"lower/prim: internal error. MkFalse should not get here."
    Prim Ty3
RequestSizeOf -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error [Char]
"lower/prim: internal error. RequestSizeOf shouldn't be here."
    Prim Ty3
RequestEndOf -> [Char] -> Prim
forall a. HasCallStack => [Char] -> a
error [Char]
"lower/prim: internal error. RequestEndOf shouldn't be here."

isTrivial' :: Exp3 -> Bool
isTrivial' :: PreExp E3Ext () Ty3 -> Bool
isTrivial' PreExp E3Ext () Ty3
e =
    case PreExp E3Ext () Ty3
e of
      (PrimAppE Prim Ty3
L3.MkTrue []) -> Bool
True
      (PrimAppE Prim Ty3
L3.MkFalse []) -> Bool
True
      PreExp E3Ext () Ty3
_ -> PreExp E3Ext () Ty3 -> Bool
forall e. Expression e => e -> Bool
isTrivial PreExp E3Ext () Ty3
e