{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}

{- L0 Specializer (part 2):
~~~~~~~~~~~~~~~~~~~~~~~~~~~

Paulette worked on a specializer which lives in 'Gibbon.L0.Specialize'
and specializes functions on curried calls. Now we need a driver which
takes these different pieces, and puts them together in order to
transform a fully polymorphic L0 program, into a monomorphic L1 program.
This module is the first attempt to do that.

-}

module Gibbon.L0.Specialize2
  (bindLambdas, monomorphize, specLambdas, desugarL0, toL1, floatOutCase)
  where

import           Control.Monad
import           Control.Monad.State
import           Data.Foldable ( foldlM, foldrM )
import qualified Data.Map as M
import qualified Data.Set as S
import           GHC.Stack (HasCallStack)
import           Text.PrettyPrint.GenericPretty

import           Gibbon.Common
import           Gibbon.Pretty
import           Gibbon.L0.Syntax
import           Gibbon.L0.Typecheck
import qualified Gibbon.L1.Syntax as L1
import Data.Bifunctor
--------------------------------------------------------------------------------

{-

Transforming L0 to L1
~~~~~~~~~~~~~~~~~~~~~

(A) Monomorphization
(B) Lambda lifting (via specialization)
(C) Convert to L1, which should be pretty straightforward at this point.



Monomorphization
~~~~~~~~~~~~~~~~

Things that can be polymorphic, and therefore should be monormorphized:
- top-level fn calls
- lamda functions
- datacons

Here's a rough plan:

(0) Walk over all datatypes and functions to collect obligations for
    polymorphic types which have been fully applied to monomorphic types in the
    source program. For example, in a function 'f :: Int -> Maybe Int', we must
    replace 'Maybe Int' with an appropriate monomorphic alternative.


(1) Start with main: walk over it, and collect all monomorphization obligations:

        { [((fn_name, [tyapp]), newname)] , [((lam_name, [tyapp]), newname)] , [((tycon, [tyapp]), newname)] }

    i.e fn_name should be monomorphized at [tyapp], and it should be named newname.

    While collecting these obligations, just replace all polymorphic things with their
    corresponding new names.

(1.2) 'main' can transitively call a polymorphic function via a monomorphic one.
      To collect those obligations, we walk over all the monomorphic functions in
      the program as well.

(2) Start monormorphizing toplevel functions, and collect any new obligations
    that may be generated. Repeat (2) until there are no more obls.

(3) Create monomorphic versions of all datatypes.

(4) After we have all the monomorphic datatypes, we need to fix TYPEs in (Packed TYPE ..) to
    have the correct suffix. Actually, this could be done in 'collectMonoObls', but we do
    it in a separate pass for now.

(5) Delete all polymorphic fns and datatypes, which should all just be dead code now.

(6) Typecheck monomorphic L0 once more.

TODOs:

(*) Curried functions are not supported atm (not even by the typechecker):
    they're a bit tricky to get right as Gibbon functions can only accept 1 argument.
(*) Support minimal 'import's in 'Gibbon.HaskellFronted'.
(*) Anonymous lambdas


Lambda lifting
~~~~~~~~~~~~~~

Assume that the input program is monomorphic.

(a) Traverse all expressions in the program (main and functions), and
    float out all lambda definitions to the top-level.

(b) Collect all function references passed in as arguments to other functions.
    E.g.

        foo :: (A -> B) -> A -> B
        main = ... (foo fn1 thing1) ... (foo fn2 thing2) ...

     => [ ((foo, [fn1]), foo_1), ((foo, [fn2]), foo_2), ... ]


(c) (foo fn1) and (foo fn2) would now be separate top-level first order functions:

        foo_1 :: A -> B
        foo_1 thing = ... fn1 thing ...

        foo_2 :: A -> B
        foo_2 thing = ... fn2 thing ...

    Create these functions, drop the lambdas from it's type, arguments etc.

-}

-- Just a mechanical transformation ..
toL1 :: Prog0 -> L1.Prog1
toL1 :: Prog0 -> Prog1
toL1 Prog{DDefs (TyOf Exp0)
ddefs :: DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs, FunDefs Exp0
fundefs :: FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs, Maybe (Exp0, TyOf Exp0)
mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} =
   DDefs (TyOf Exp1)
-> FunDefs Exp1 -> Maybe (Exp1, TyOf Exp1) -> Prog1
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog ((DDef0 -> DDef1) -> Map Var DDef0 -> Map Var DDef1
forall a b k. (a -> b) -> Map k a -> Map k b
M.map DDef0 -> DDef1
toL1DDef DDefs (TyOf Exp0)
Map Var DDef0
ddefs) ((FunDef0 -> FunDef Exp1) -> FunDefs Exp0 -> FunDefs Exp1
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FunDef0 -> FunDef Exp1
toL1FunDef FunDefs Exp0
fundefs) Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, Ty1)
mainExp'
  where
    mainExp' :: Maybe (Exp1, Ty1)
mainExp' = case Maybe (Exp0, TyOf Exp0)
mainExp of
                 Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp1, Ty1)
forall a. Maybe a
Nothing
                 Just (Exp0
e,TyOf Exp0
ty) -> (Exp1, Ty1) -> Maybe (Exp1, Ty1)
forall a. a -> Maybe a
Just (Exp0 -> Exp1
toL1Exp Exp0
e, Ty0 -> Ty1
toL1Ty TyOf Exp0
Ty0
ty)

    toL1DDef :: DDef0 -> L1.DDef1
    toL1DDef :: DDef0 -> DDef1
toL1DDef ddf :: DDef0
ddf@DDef{[([Char], [(IsBoxed, Ty0)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons} =
      DDef0
ddf { dataCons :: [([Char], [(IsBoxed, Ty1)])]
dataCons = (([Char], [(IsBoxed, Ty0)]) -> ([Char], [(IsBoxed, Ty1)]))
-> [([Char], [(IsBoxed, Ty0)])] -> [([Char], [(IsBoxed, Ty1)])]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
dcon, [(IsBoxed, Ty0)]
btys) -> ([Char]
dcon, ((IsBoxed, Ty0) -> (IsBoxed, Ty1))
-> [(IsBoxed, Ty0)] -> [(IsBoxed, Ty1)]
forall a b. (a -> b) -> [a] -> [b]
map (\(IsBoxed
a,Ty0
b) -> (IsBoxed
a, Ty0 -> Ty1
toL1Ty Ty0
b)) [(IsBoxed, Ty0)]
btys)) [([Char], [(IsBoxed, Ty0)])]
dataCons }

    toL1FunDef :: FunDef0 -> L1.FunDef1
    toL1FunDef :: FunDef0 -> FunDef Exp1
toL1FunDef fn :: FunDef0
fn@FunDef{ArrowTy (TyOf Exp0)
funTy :: ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy, Exp0
funBody :: Exp0
funBody :: forall ex. FunDef ex -> ex
funBody} =
      FunDef0
fn { funTy :: ArrowTy (TyOf Exp1)
funTy = ArrowTy Ty0 -> ArrowTy Ty1
toL1TyS ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy
         , funBody :: Exp1
funBody = Exp0 -> Exp1
toL1Exp Exp0
funBody }

    toL1Exp :: Exp0 -> L1.Exp1
    toL1Exp :: Exp0 -> Exp1
toL1Exp Exp0
ex =
      case Exp0
ex of
        VarE Var
v    -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L1.VarE Var
v
        LitE Int
n    -> Int -> Exp1
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
L1.LitE Int
n
        CharE Char
n   -> Char -> Exp1
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
L1.CharE Char
n
        FloatE Double
n  -> Double -> Exp1
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
L1.FloatE Double
n
        LitSymE Var
v -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L1.LitSymE Var
v
        AppE Var
f [] [Exp0]
args   -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
args)
        AppE{}   -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        PrimAppE Prim Ty0
pr [Exp0]
args ->
          case Prim Ty0
pr of
            -- This is always going to have a function reference which
            -- we cannot eliminate.
            VSortP{} ->
              case [Exp0]
args of
                [Exp0
ls, Ext (FunRefE [Ty0]
_ Var
fp)] ->
                  Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Prim Ty0 -> Prim Ty1
toL1Prim Prim Ty0
pr) [Exp0 -> Exp1
toL1Exp Exp0
ls, Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                [Exp0
ls, Ext (L Loc
_ (Ext (FunRefE [Ty0]
_ Var
fp)))] ->
                  Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Prim Ty0 -> Prim Ty1
toL1Prim Prim Ty0
pr) [Exp0 -> Exp1
toL1Exp Exp0
ls, Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                [Exp0]
_ -> Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Prim Ty0 -> Prim Ty1
toL1Prim Prim Ty0
pr)((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
args)
            Prim Ty0
_ -> Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Prim Ty0 -> Prim Ty1
toL1Prim Prim Ty0
pr) ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
args)
        LetE (Var
v,[],Ty0
ty,Exp0
rhs) Exp0
bod -> (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[], Ty0 -> Ty1
toL1Ty Ty0
ty, Exp0 -> Exp1
toL1Exp Exp0
rhs) (Exp0 -> Exp1
toL1Exp Exp0
bod)
        LetE{} -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        IfE Exp0
a Exp0
b Exp0
c  -> Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp1
toL1Exp Exp0
a) (Exp0 -> Exp1
toL1Exp Exp0
b) (Exp0 -> Exp1
toL1Exp Exp0
c)
        MkProdE [Exp0]
ls -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
ls)
        ProjE Int
i Exp0
a  -> Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp0 -> Exp1
toL1Exp Exp0
a)
        CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> Exp1 -> [([Char], [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp0 -> Exp1
toL1Exp Exp0
scrt) ((([Char], [(Var, Ty0)], Exp0) -> ([Char], [(Var, ())], Exp1))
-> [([Char], [(Var, Ty0)], Exp0)] -> [([Char], [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
a,[(Var, Ty0)]
b,Exp0
c) -> ([Char]
a,
                                                                  ((Var, Ty0) -> (Var, ())) -> [(Var, Ty0)] -> [(Var, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
x,Ty0
_) -> (Var
x,())) [(Var, Ty0)]
b,
                                                                  Exp0 -> Exp1
toL1Exp Exp0
c) )
                                                    [([Char], [(Var, Ty0)], Exp0)]
brs)
        DataConE (ProdTy []) [Char]
dcon [Exp0]
ls -> () -> [Char] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () [Char]
dcon ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
ls)
        DataConE{} -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        TimeIt Exp0
e Ty0
ty IsBoxed
b    -> Exp1 -> Ty1 -> IsBoxed -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt (Exp0 -> Exp1
toL1Exp Exp0
e) (Ty0 -> Ty1
toL1Ty Ty0
ty) IsBoxed
b
        SpawnE Var
f [] [Exp0]
args -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [] ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
args)
        SpawnE{} -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        Exp0
SyncE            -> Exp1
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
        WithArenaE Var
v Exp0
e -> Var -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (Exp0 -> Exp1
toL1Exp Exp0
e)
        MapE{}  -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        FoldE{} -> [Char] -> Exp1
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        Ext E0Ext Ty0 Ty0
ext ->
          case E0Ext Ty0 Ty0
ext of
            LambdaE{}  -> [Char] -> Exp1
forall {a}. [Char] -> a
err2 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            PolyAppE{} -> [Char] -> Exp1
forall {a}. [Char] -> a
err2 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            FunRefE{}  -> [Char] -> Exp1
forall {a}. [Char] -> a
err2 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            BenchE Var
fn [Ty0]
tyapps [Exp0]
args IsBoxed
b ->
              case [Ty0]
tyapps of
                [] -> E1Ext () Ty1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E1Ext () Ty1 -> Exp1) -> E1Ext () Ty1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Var -> [()] -> [Exp1] -> IsBoxed -> E1Ext () Ty1
forall loc dec.
Var -> [loc] -> [PreExp E1Ext loc dec] -> IsBoxed -> E1Ext loc dec
L1.BenchE Var
fn [] ((Exp0 -> Exp1) -> [Exp0] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp1
toL1Exp [Exp0]
args) IsBoxed
b
                [Ty0]
_  -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error [Char]
"toL1: Polymorphic 'bench' not supported yet."
            ParE0{} -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error [Char]
"toL1: ParE0"
            PrintPacked{} -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error [Char]
"toL1: PrintPacked"
            CopyPacked{} -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error [Char]
"toL1: CopyPacked"
            TravPacked{} -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error [Char]
"toL1: TravPacked"
            LinearExt{} -> [Char] -> Exp1
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp1) -> [Char] -> Exp1
forall a b. (a -> b) -> a -> b
$ [Char]
"toL1: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
            -- Erase srclocs while going to L1
            L Loc
_ Exp0
e   -> Exp0 -> Exp1
toL1Exp Exp0
e

    toL1Prim :: Prim Ty0 -> Prim L1.Ty1
    toL1Prim :: Prim Ty0 -> Prim Ty1
toL1Prim = (Ty0 -> Ty1) -> Prim Ty0 -> Prim Ty1
forall a b. (a -> b) -> Prim a -> Prim b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ty0 -> Ty1
toL1Ty

    toL1Ty :: Ty0 -> L1.Ty1
    toL1Ty :: Ty0 -> Ty1
toL1Ty Ty0
ty =
      case Ty0
ty of
        Ty0
CharTy  -> Ty1
forall loc. UrTy loc
L1.CharTy
        Ty0
IntTy   -> Ty1
forall loc. UrTy loc
L1.IntTy
        Ty0
FloatTy -> Ty1
forall loc. UrTy loc
L1.FloatTy
        Ty0
SymTy0  -> Ty1
forall loc. UrTy loc
L1.SymTy
        Ty0
BoolTy  -> Ty1
forall loc. UrTy loc
L1.BoolTy
        TyVar{} -> [Char] -> Ty1
forall {a}. [Char] -> a
err1 (Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty)
        MetaTv{} -> [Char] -> Ty1
forall {a}. [Char] -> a
err1 (Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty)
        ProdTy [Ty0]
tys  -> [Ty1] -> Ty1
forall loc. [UrTy loc] -> UrTy loc
L1.ProdTy ([Ty1] -> Ty1) -> [Ty1] -> Ty1
forall a b. (a -> b) -> a -> b
$ (Ty0 -> Ty1) -> [Ty0] -> [Ty1]
forall a b. (a -> b) -> [a] -> [b]
map Ty0 -> Ty1
toL1Ty [Ty0]
tys
        SymDictTy (Just Var
v) Ty0
a -> Maybe Var -> Ty1 -> Ty1
forall loc. Maybe Var -> Ty1 -> UrTy loc
L1.SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v) (Ty1 -> Ty1) -> Ty1 -> Ty1
forall a b. (a -> b) -> a -> b
$ Ty0 -> Ty1
toL1Ty Ty0
a
        SymDictTy Maybe Var
Nothing  Ty0
a -> Maybe Var -> Ty1 -> Ty1
forall loc. Maybe Var -> Ty1 -> UrTy loc
L1.SymDictTy Maybe Var
forall a. Maybe a
Nothing (Ty1 -> Ty1) -> Ty1 -> Ty1
forall a b. (a -> b) -> a -> b
$ Ty0 -> Ty1
toL1Ty Ty0
a
        PDictTy Ty0
k Ty0
v -> Ty1 -> Ty1 -> Ty1
forall loc. UrTy loc -> UrTy loc -> UrTy loc
L1.PDictTy (Ty0 -> Ty1
toL1Ty Ty0
k) (Ty0 -> Ty1
toL1Ty Ty0
v)
        ArrowTy{} -> [Char] -> Ty1
forall {a}. [Char] -> a
err2 (Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty)
        PackedTy [Char]
tycon [Ty0]
tyapps | [Ty0]
tyapps [Ty0] -> [Ty0] -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== [] -> [Char] -> () -> Ty1
forall loc. [Char] -> loc -> UrTy loc
L1.PackedTy [Char]
tycon ()
                              | IsBoxed
otherwise    -> [Char] -> Ty1
forall {a}. [Char] -> a
err1 (Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty)
        Ty0
ArenaTy -> Ty1
forall loc. UrTy loc
L1.ArenaTy
        Ty0
SymSetTy -> Ty1
forall loc. UrTy loc
L1.SymSetTy
        Ty0
SymHashTy -> Ty1
forall loc. UrTy loc
L1.SymHashTy
        Ty0
IntHashTy -> Ty1
forall loc. UrTy loc
L1.IntHashTy
        VectorTy Ty0
a  -> Ty1 -> Ty1
forall loc. UrTy loc -> UrTy loc
L1.VectorTy (Ty0 -> Ty1
toL1Ty Ty0
a)
        ListTy Ty0
a  -> Ty1 -> Ty1
forall loc. UrTy loc -> UrTy loc
L1.ListTy (Ty0 -> Ty1
toL1Ty Ty0
a)

    toL1TyS :: ArrowTy Ty0 -> ArrowTy L1.Ty1
    toL1TyS :: ArrowTy Ty0 -> ArrowTy Ty1
toL1TyS t :: ArrowTy Ty0
t@(ForAll [TyVar]
tyvars (ArrowTy [Ty0]
as Ty0
b))
      | [TyVar]
tyvars [TyVar] -> [TyVar] -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== [] = ((Ty0 -> Ty1) -> [Ty0] -> [Ty1]
forall a b. (a -> b) -> [a] -> [b]
map Ty0 -> Ty1
toL1Ty [Ty0]
as, Ty0 -> Ty1
toL1Ty Ty0
b)
      | IsBoxed
otherwise    = [Char] -> ([Ty1], Ty1)
forall {a}. [Char] -> a
err1 (TyScheme -> [Char]
forall a. Out a => a -> [Char]
sdoc ArrowTy Ty0
TyScheme
t)
    toL1TyS (ForAll [TyVar]
_ Ty0
t) = [Char] -> ArrowTy Ty1
forall a. HasCallStack => [Char] -> a
error ([Char] -> ArrowTy Ty1) -> [Char] -> ArrowTy Ty1
forall a b. (a -> b) -> a -> b
$ [Char]
"toL1: Not a function type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
t

    err1 :: [Char] -> a
err1 [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"toL1: Program was not fully monomorphized. Encountered: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg

    err2 :: [Char] -> a
err2 [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"toL1: Could not lift all lambdas. Encountered: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg

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

-- The monomorphization monad.
type MonoM a = StateT MonoState PassM a

data MonoState = MonoState
  { MonoState -> Map (Var, [Ty0]) Var
mono_funs_worklist :: M.Map (Var, [Ty0]) Var
  , MonoState -> Map (Var, [Ty0]) Var
mono_funs_done :: M.Map (Var, [Ty0]) Var
  , MonoState -> Map (Var, [Ty0]) Var
mono_lams      :: M.Map (Var, [Ty0]) Var
  , MonoState -> Map ([Char], [Ty0]) Var
mono_dcons     :: M.Map (TyCon, [Ty0]) Var -- suffix
  }
  deriving (Int -> MonoState -> [Char] -> [Char]
[MonoState] -> [Char] -> [Char]
MonoState -> [Char]
(Int -> MonoState -> [Char] -> [Char])
-> (MonoState -> [Char])
-> ([MonoState] -> [Char] -> [Char])
-> Show MonoState
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> MonoState -> [Char] -> [Char]
showsPrec :: Int -> MonoState -> [Char] -> [Char]
$cshow :: MonoState -> [Char]
show :: MonoState -> [Char]
$cshowList :: [MonoState] -> [Char] -> [Char]
showList :: [MonoState] -> [Char] -> [Char]
Show, ReadPrec [MonoState]
ReadPrec MonoState
Int -> ReadS MonoState
ReadS [MonoState]
(Int -> ReadS MonoState)
-> ReadS [MonoState]
-> ReadPrec MonoState
-> ReadPrec [MonoState]
-> Read MonoState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MonoState
readsPrec :: Int -> ReadS MonoState
$creadList :: ReadS [MonoState]
readList :: ReadS [MonoState]
$creadPrec :: ReadPrec MonoState
readPrec :: ReadPrec MonoState
$creadListPrec :: ReadPrec [MonoState]
readListPrec :: ReadPrec [MonoState]
Read, Eq MonoState
Eq MonoState
-> (MonoState -> MonoState -> Ordering)
-> (MonoState -> MonoState -> IsBoxed)
-> (MonoState -> MonoState -> IsBoxed)
-> (MonoState -> MonoState -> IsBoxed)
-> (MonoState -> MonoState -> IsBoxed)
-> (MonoState -> MonoState -> MonoState)
-> (MonoState -> MonoState -> MonoState)
-> Ord MonoState
MonoState -> MonoState -> IsBoxed
MonoState -> MonoState -> Ordering
MonoState -> MonoState -> MonoState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> IsBoxed)
-> (a -> a -> IsBoxed)
-> (a -> a -> IsBoxed)
-> (a -> a -> IsBoxed)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MonoState -> MonoState -> Ordering
compare :: MonoState -> MonoState -> Ordering
$c< :: MonoState -> MonoState -> IsBoxed
< :: MonoState -> MonoState -> IsBoxed
$c<= :: MonoState -> MonoState -> IsBoxed
<= :: MonoState -> MonoState -> IsBoxed
$c> :: MonoState -> MonoState -> IsBoxed
> :: MonoState -> MonoState -> IsBoxed
$c>= :: MonoState -> MonoState -> IsBoxed
>= :: MonoState -> MonoState -> IsBoxed
$cmax :: MonoState -> MonoState -> MonoState
max :: MonoState -> MonoState -> MonoState
$cmin :: MonoState -> MonoState -> MonoState
min :: MonoState -> MonoState -> MonoState
Ord, MonoState -> MonoState -> IsBoxed
(MonoState -> MonoState -> IsBoxed)
-> (MonoState -> MonoState -> IsBoxed) -> Eq MonoState
forall a. (a -> a -> IsBoxed) -> (a -> a -> IsBoxed) -> Eq a
$c== :: MonoState -> MonoState -> IsBoxed
== :: MonoState -> MonoState -> IsBoxed
$c/= :: MonoState -> MonoState -> IsBoxed
/= :: MonoState -> MonoState -> IsBoxed
Eq, (forall x. MonoState -> Rep MonoState x)
-> (forall x. Rep MonoState x -> MonoState) -> Generic MonoState
forall x. Rep MonoState x -> MonoState
forall x. MonoState -> Rep MonoState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MonoState -> Rep MonoState x
from :: forall x. MonoState -> Rep MonoState x
$cto :: forall x. Rep MonoState x -> MonoState
to :: forall x. Rep MonoState x -> MonoState
Generic, Int -> MonoState -> Doc
[MonoState] -> Doc
MonoState -> Doc
(Int -> MonoState -> Doc)
-> (MonoState -> Doc) -> ([MonoState] -> Doc) -> Out MonoState
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> MonoState -> Doc
docPrec :: Int -> MonoState -> Doc
$cdoc :: MonoState -> Doc
doc :: MonoState -> Doc
$cdocList :: [MonoState] -> Doc
docList :: [MonoState] -> Doc
Out)

emptyMonoState :: MonoState
emptyMonoState :: MonoState
emptyMonoState = MonoState
  { mono_funs_worklist :: Map (Var, [Ty0]) Var
mono_funs_worklist = Map (Var, [Ty0]) Var
forall k a. Map k a
M.empty, mono_funs_done :: Map (Var, [Ty0]) Var
mono_funs_done = Map (Var, [Ty0]) Var
forall k a. Map k a
M.empty
  , mono_lams :: Map (Var, [Ty0]) Var
mono_lams = Map (Var, [Ty0]) Var
forall k a. Map k a
M.empty, mono_dcons :: Map ([Char], [Ty0]) Var
mono_dcons = Map ([Char], [Ty0]) Var
forall k a. Map k a
M.empty }

extendFuns :: (Var,[Ty0]) -> Var -> MonoState -> MonoState
extendFuns :: (Var, [Ty0]) -> Var -> MonoState -> MonoState
extendFuns (Var, [Ty0])
k Var
v mono_st :: MonoState
mono_st@MonoState{Map (Var, [Ty0]) Var
mono_funs_worklist :: MonoState -> Map (Var, [Ty0]) Var
mono_funs_worklist :: Map (Var, [Ty0]) Var
mono_funs_worklist} =
  MonoState
mono_st { mono_funs_worklist :: Map (Var, [Ty0]) Var
mono_funs_worklist = (Var, [Ty0]) -> Var -> Map (Var, [Ty0]) Var -> Map (Var, [Ty0]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var, [Ty0])
k Var
v Map (Var, [Ty0]) Var
mono_funs_worklist }

extendLambdas :: (Var,[Ty0]) -> Var -> MonoState -> MonoState
extendLambdas :: (Var, [Ty0]) -> Var -> MonoState -> MonoState
extendLambdas (Var, [Ty0])
k Var
v mono_st :: MonoState
mono_st@MonoState{Map (Var, [Ty0]) Var
mono_lams :: MonoState -> Map (Var, [Ty0]) Var
mono_lams :: Map (Var, [Ty0]) Var
mono_lams} =
  MonoState
mono_st { mono_lams :: Map (Var, [Ty0]) Var
mono_lams = (Var, [Ty0]) -> Var -> Map (Var, [Ty0]) Var -> Map (Var, [Ty0]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var, [Ty0])
k Var
v Map (Var, [Ty0]) Var
mono_lams }

extendDatacons :: (TyCon,[Ty0]) -> Var -> MonoState -> MonoState
extendDatacons :: ([Char], [Ty0]) -> Var -> MonoState -> MonoState
extendDatacons ([Char], [Ty0])
k Var
v mono_st :: MonoState
mono_st@MonoState{Map ([Char], [Ty0]) Var
mono_dcons :: MonoState -> Map ([Char], [Ty0]) Var
mono_dcons :: Map ([Char], [Ty0]) Var
mono_dcons} =
  MonoState
mono_st { mono_dcons :: Map ([Char], [Ty0]) Var
mono_dcons = ([Char], [Ty0])
-> Var -> Map ([Char], [Ty0]) Var -> Map ([Char], [Ty0]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ([Char], [Ty0])
k Var
v Map ([Char], [Ty0]) Var
mono_dcons }

-- We need this wrapper because of the way these maps are defined.
--
-- getLambdaObls id { mono_lams = [ ((id,[IntTy]), id1), ((id,[BoolTy]), id2) ] }
--   = [ (id2, [IntTy]), (id2, [BoolTy]) ]
getLambdaObls :: Var -> MonoState -> (M.Map Var [Ty0])
getLambdaObls :: Var -> MonoState -> Map Var [Ty0]
getLambdaObls Var
f MonoState{Map (Var, [Ty0]) Var
mono_lams :: MonoState -> Map (Var, [Ty0]) Var
mono_lams :: Map (Var, [Ty0]) Var
mono_lams} =
  [(Var, [Ty0])] -> Map Var [Ty0]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, [Ty0])] -> Map Var [Ty0])
-> [(Var, [Ty0])] -> Map Var [Ty0]
forall a b. (a -> b) -> a -> b
$ (((Var, [Ty0]), Var) -> (Var, [Ty0]))
-> [((Var, [Ty0]), Var)] -> [(Var, [Ty0])]
forall a b. (a -> b) -> [a] -> [b]
map (\((Var
_,[Ty0]
tys), Var
w) -> (Var
w, [Ty0]
tys)) [((Var, [Ty0]), Var)]
f_mono_st
  where
    f_mono_st :: [((Var, [Ty0]), Var)]
f_mono_st = (((Var, [Ty0]), Var) -> IsBoxed)
-> [((Var, [Ty0]), Var)] -> [((Var, [Ty0]), Var)]
forall a. (a -> IsBoxed) -> [a] -> [a]
filter (\((Var
v,[Ty0]
_), Var
_) -> Var
v Var -> Var -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== Var
f) (Map (Var, [Ty0]) Var -> [((Var, [Ty0]), Var)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Var, [Ty0]) Var
mono_lams)


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

monomorphize :: Prog0 -> PassM Prog0
monomorphize :: Prog0 -> PassM Prog0
monomorphize p :: Prog0
p@Prog{DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs :: DDefs (TyOf Exp0)
ddefs,FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp0
fundefs,Maybe (Exp0, TyOf Exp0)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp} = do
  let env2 :: Env2 Ty0
env2 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 TyEnv Ty0
forall k a. Map k a
M.empty ((FunDef0 -> TyScheme) -> FunDefs Exp0 -> Map Var TyScheme
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FunDef0 -> ArrowTy (TyOf Exp0)
FunDef0 -> TyScheme
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDefs Exp0
fundefs)

  let mono_m :: StateT MonoState PassM Prog0
mono_m = do
        -- Step (0)
        ([DDef0]
ddfs0 :: [DDef0]) <- (DDef0 -> StateT MonoState PassM DDef0)
-> [DDef0] -> StateT MonoState PassM [DDef0]
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 Var DDef0 -> DDef0 -> StateT MonoState PassM DDef0
monoOblsDDef DDefs (TyOf Exp0)
Map Var DDef0
ddefs) (Map Var DDef0 -> [DDef0]
forall k a. Map k a -> [a]
M.elems DDefs (TyOf Exp0)
Map Var DDef0
ddefs)
        let ddefs' :: Map Var DDef0
ddefs' = [(Var, DDef0)] -> Map Var DDef0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, DDef0)] -> Map Var DDef0)
-> [(Var, DDef0)] -> Map Var DDef0
forall a b. (a -> b) -> a -> b
$ (DDef0 -> (Var, DDef0)) -> [DDef0] -> [(Var, DDef0)]
forall a b. (a -> b) -> [a] -> [b]
map (\DDef0
a -> (DDef0 -> Var
forall a. DDef a -> Var
tyName DDef0
a,DDef0
a)) [DDef0]
ddfs0
        -- Step (1)
        Maybe (Exp0, Ty0)
mainExp' <-
          case Maybe (Exp0, TyOf Exp0)
mainExp of
            Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp0, Ty0) -> StateT MonoState PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
            Just (Exp0
e,TyOf Exp0
ty) -> do
              Exp0
mainExp'  <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs' Env2 Ty0
env2 Set Var
toplevel Exp0
e
              Exp0
mainExp'' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
mainExp'
              MonoState
mono_st   <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
              MonoState -> StateT MonoState PassM ()
forall (m :: * -> *). (Monad m, HasCallStack) => MonoState -> m ()
assertLambdasMonomorphized MonoState
mono_st
              Maybe (Exp0, Ty0) -> StateT MonoState PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Exp0, Ty0) -> StateT MonoState PassM (Maybe (Exp0, Ty0)))
-> Maybe (Exp0, Ty0) -> StateT MonoState PassM (Maybe (Exp0, Ty0))
forall a b. (a -> b) -> a -> b
$ (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just (Exp0
mainExp'', TyOf Exp0
Ty0
ty)
        -- Step (1.2)
        let mono_funs :: FunDefs Exp0
mono_funs = (FunDef0 -> IsBoxed) -> FunDefs Exp0 -> FunDefs Exp0
forall a k. (a -> IsBoxed) -> Map k a -> Map k a
M.filter FunDef0 -> IsBoxed
isMonoFun FunDefs Exp0
fundefs
        FunDefs Exp0
mono_funs' <-
          (FunDefs Exp0 -> FunDef0 -> StateT MonoState PassM (FunDefs Exp0))
-> FunDefs Exp0
-> [FunDef0]
-> StateT MonoState PassM (FunDefs Exp0)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
            (\FunDefs Exp0
funs fn :: FunDef0
fn@FunDef{[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,Var
funName :: Var
funName :: forall ex. FunDef ex -> Var
funName,Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody,ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy} -> do
                  let env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty0)] -> TyEnv Ty0) -> [(Var, Ty0)] -> TyEnv Ty0
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy)) Env2 Ty0
env2
                  let (ForAll [TyVar]
tyvars (ArrowTy [Ty0]
as Ty0
b)) = ArrowTy (TyOf Exp0)
funTy
                  [Ty0]
as' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy DDefs (TyOf Exp0)
Map Var DDef0
ddefs) [Ty0]
as
                  Ty0
b'  <- Map Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy DDefs (TyOf Exp0)
Map Var DDef0
ddefs Ty0
b
                  Exp0
funBody'  <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs' Env2 Ty0
env2' Set Var
toplevel Exp0
funBody
                  Exp0
funBody'' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
funBody'
                  MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
                  MonoState -> StateT MonoState PassM ()
forall (m :: * -> *). (Monad m, HasCallStack) => MonoState -> m ()
assertLambdasMonomorphized MonoState
mono_st
                  let fn' :: FunDef0
fn' = FunDef0
fn { funBody :: Exp0
funBody = Exp0
funBody'', funTy :: ArrowTy (TyOf Exp0)
funTy = [TyVar] -> Ty0 -> TyScheme
ForAll [TyVar]
tyvars ([Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
as' Ty0
b')}
                  FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0))
-> FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
forall a b. (a -> b) -> a -> b
$ Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
funName FunDef0
fn' FunDefs Exp0
funs)
            FunDefs Exp0
mono_funs
            (FunDefs Exp0 -> [FunDef0]
forall k a. Map k a -> [a]
M.elems FunDefs Exp0
mono_funs)
        let fundefs' :: FunDefs Exp0
fundefs' = FunDefs Exp0
mono_funs' FunDefs Exp0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` FunDefs Exp0
fundefs
        -- Step (2)
        FunDefs Exp0
fundefs'' <- FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
monoFunDefs FunDefs Exp0
fundefs'
        -- N.B. Important to fetch the state before we run 'monoDDefs' which
        -- clears everything in 'mono_dcons'.
        MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
        -- Step (3)
        Map Var DDef0
ddefs'' <- Map Var DDef0 -> MonoM (Map Var DDef0)
monoDDefs Map Var DDef0
ddefs'
        let p3 :: Prog0
p3 = Prog0
p { ddefs :: DDefs (TyOf Exp0)
ddefs = DDefs (TyOf Exp0)
Map Var DDef0
ddefs'', fundefs :: FunDefs Exp0
fundefs = FunDefs Exp0
fundefs'', mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp = Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp' }
        let p3' :: Prog0
p3' = MonoState -> Prog0 -> Prog0
updateTyCons MonoState
mono_st Prog0
p3
        -- Important; p3 is not type-checkable until updateTyCons runs.
        -- Step (4)
        PassM Prog0 -> StateT MonoState PassM Prog0
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Prog0 -> StateT MonoState PassM Prog0)
-> PassM Prog0 -> StateT MonoState PassM Prog0
forall a b. (a -> b) -> a -> b
$ Prog0 -> PassM Prog0
tcProg Prog0
p3'

  (Prog0
p4,MonoState
_) <- StateT MonoState PassM Prog0
-> MonoState -> PassM (Prog0, MonoState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT MonoState PassM Prog0
mono_m MonoState
emptyMonoState

  -- Step (5)
  let p5 :: Prog0
p5  = Prog0 -> Prog0
purgePolyDDefs Prog0
p4
  let p5' :: Prog0
p5' = Prog0 -> Prog0
purgePolyFuns Prog0
p5

-- Step (6)
  Prog0 -> PassM Prog0
tcProg Prog0
p5'
  where
    toplevel :: Set Var
toplevel = FunDefs Exp0 -> Set Var
forall k a. Map k a -> Set k
M.keysSet FunDefs Exp0
fundefs

    -- Create monomorphic versions of all polymorphic functions.
    monoFunDefs :: FunDefs0 -> MonoM FunDefs0
    monoFunDefs :: FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
monoFunDefs FunDefs Exp0
fundefs1 = do
      MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
      if Map (Var, [Ty0]) Var -> IsBoxed
forall k a. Map k a -> IsBoxed
M.null (MonoState -> Map (Var, [Ty0]) Var
mono_funs_worklist MonoState
mono_st)
      then FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunDefs Exp0
fundefs1
      else do
        let (((Var
fun_name, [Ty0]
tyapps), Var
new_fun_name):[((Var, [Ty0]), Var)]
rst) = Map (Var, [Ty0]) Var -> [((Var, [Ty0]), Var)]
forall k a. Map k a -> [(k, a)]
M.toList (MonoState -> Map (Var, [Ty0]) Var
mono_funs_worklist MonoState
mono_st)
            fn :: FunDef0
fn@FunDef{[Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs, Var
funName :: forall ex. FunDef ex -> Var
funName :: Var
funName, Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} = FunDefs Exp0
fundefs FunDefs Exp0 -> Var -> FunDef0
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
fun_name
            tyvars :: [TyVar]
tyvars = TyScheme -> [TyVar]
tyVarsFromScheme (FunDef0 -> ArrowTy (TyOf Exp0)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef0
fn)
        [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"While monormorphizing the function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
forall a. Out a => a -> [Char]
sdoc Var
funName) [TyVar]
tyvars [Ty0]
tyapps
        let mp :: Map TyVar Ty0
mp = [(TyVar, Ty0)] -> Map TyVar Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TyVar, Ty0)] -> Map TyVar Ty0)
-> [(TyVar, Ty0)] -> Map TyVar Ty0
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Ty0] -> [(TyVar, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tyvars [Ty0]
tyapps
            funTy' :: TyScheme
funTy' = [TyVar] -> Ty0 -> TyScheme
ForAll [] (Map TyVar Ty0 -> Ty0 -> Ty0
substTyVar Map TyVar Ty0
mp (TyScheme -> Ty0
tyFromScheme (FunDef0 -> ArrowTy (TyOf Exp0)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef0
fn)))
            funBody' :: Exp0
funBody' = Map TyVar Ty0 -> Exp0 -> Exp0
substTyVarExp Map TyVar Ty0
mp Exp0
funBody
            -- Move this obligation from todo to done.
            mono_st' :: MonoState
mono_st' = MonoState
mono_st { mono_funs_done :: Map (Var, [Ty0]) Var
mono_funs_done = (Var, [Ty0]) -> Var -> Map (Var, [Ty0]) Var -> Map (Var, [Ty0]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fun_name, [Ty0]
tyapps) Var
new_fun_name (MonoState -> Map (Var, [Ty0]) Var
mono_funs_done MonoState
mono_st)
                               , mono_funs_worklist :: Map (Var, [Ty0]) Var
mono_funs_worklist = [((Var, [Ty0]), Var)] -> Map (Var, [Ty0]) Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((Var, [Ty0]), Var)]
rst }
        MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st'
        -- Collect any more obligations generated due to the monormorphization
        let argEnv :: TyEnv Ty0
argEnv = [(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty0)] -> TyEnv Ty0) -> [(Var, Ty0)] -> TyEnv Ty0
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy Ty0
TyScheme
funTy')
        let (TyEnv Ty0
argFenv, TyEnv Ty0
argVenv) = (Ty0 -> IsBoxed) -> TyEnv Ty0 -> (TyEnv Ty0, TyEnv Ty0)
forall a k. (a -> IsBoxed) -> Map k a -> (Map k a, Map k a)
M.partition (\case ArrowTy {} -> IsBoxed
True; Ty0
_ -> IsBoxed
False) TyEnv Ty0
argEnv
        let argFenv' :: Map Var TyScheme
argFenv' = (Ty0 -> TyScheme) -> TyEnv Ty0 -> Map Var TyScheme
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ([TyVar] -> Ty0 -> TyScheme
ForAll []) TyEnv Ty0
argFenv
        let env21 :: Env2 Ty0
env21 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 TyEnv Ty0
argVenv (Map Var TyScheme -> Map Var TyScheme -> Map Var TyScheme
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Var TyScheme
argFenv' ((FunDef0 -> TyScheme) -> FunDefs Exp0 -> Map Var TyScheme
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FunDef0 -> ArrowTy (TyOf Exp0)
FunDef0 -> TyScheme
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDefs Exp0
fundefs1))
        Exp0
funBody'' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls DDefs (TyOf Exp0)
Map Var DDef0
ddefs Env2 Ty0
env21 Set Var
toplevel Exp0
funBody'
        Exp0
funBody''' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
funBody''
        let fn' :: FunDef0
fn' = FunDef0
fn { funName :: Var
funName = Var
new_fun_name, funTy :: ArrowTy (TyOf Exp0)
funTy = ArrowTy (TyOf Exp0)
TyScheme
funTy', funBody :: Exp0
funBody = Exp0
funBody''' }
        FunDefs Exp0 -> StateT MonoState PassM (FunDefs Exp0)
monoFunDefs (Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
new_fun_name FunDef0
fn' FunDefs Exp0
fundefs1)

    -- Create monomorphic versions of all polymorphic datatypes.
    monoDDefs :: DDefs0 -> MonoM DDefs0
    monoDDefs :: Map Var DDef0 -> MonoM (Map Var DDef0)
monoDDefs Map Var DDef0
ddefs1 = do
      MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
      if Map ([Char], [Ty0]) Var -> IsBoxed
forall k a. Map k a -> IsBoxed
M.null (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st)
      then Map Var DDef0 -> MonoM (Map Var DDef0)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Var DDef0
ddefs1
      else do
        let ((([Char]
tycon, [Ty0]
tyapps), Var
suffix):[(([Char], [Ty0]), Var)]
rst) = Map ([Char], [Ty0]) Var -> [(([Char], [Ty0]), Var)]
forall k a. Map k a -> [(k, a)]
M.toList (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st)
            ddf :: DDef0
ddf@DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName,[TyVar]
tyArgs :: [TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs,[([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = Map Var DDef0 -> [Char] -> DDef0
forall a. Out a => DDefs a -> [Char] -> DDef a
lookupDDef DDefs (TyOf Exp0)
Map Var DDef0
ddefs [Char]
tycon
        [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"In the datacon: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
forall a. Out a => a -> [Char]
sdoc Var
tyName) [TyVar]
tyArgs [Ty0]
tyapps
        let tyName' :: Var
tyName' = Var -> Var -> Var
varAppend Var
tyName Var
suffix
            dataCons' :: [([Char], [(IsBoxed, Ty0)])]
dataCons' = (([Char], [(IsBoxed, Ty0)]) -> ([Char], [(IsBoxed, Ty0)]))
-> [([Char], [(IsBoxed, Ty0)])] -> [([Char], [(IsBoxed, Ty0)])]
forall a b. (a -> b) -> [a] -> [b]
map
                          (\([Char]
dcon,[(IsBoxed, Ty0)]
vtys) ->
                            let ([IsBoxed]
vars,[Ty0]
tys) = [(IsBoxed, Ty0)] -> ([IsBoxed], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(IsBoxed, Ty0)]
vtys
                                sbst :: Map TyVar Ty0
sbst = [(TyVar, Ty0)] -> Map TyVar Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([TyVar] -> [Ty0] -> [(TyVar, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tyArgs [Ty0]
tyapps)
                                tys' :: [Ty0]
tys' = (Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (Map TyVar Ty0 -> Ty0 -> Ty0
substTyVar Map TyVar Ty0
sbst) [Ty0]
tys
                                tys'' :: [Ty0]
tys'' = (Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs1 MonoState
mono_st) [Ty0]
tys'
                                vtys' :: [(IsBoxed, Ty0)]
vtys' = [IsBoxed] -> [Ty0] -> [(IsBoxed, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsBoxed]
vars [Ty0]
tys''
                            in ([Char]
dcon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
suffix, [(IsBoxed, Ty0)]
vtys'))
                          [([Char], [(IsBoxed, Ty0)])]
dataCons
            ddefs1' :: Map Var DDef0
ddefs1' = Var -> DDef0 -> Map Var DDef0 -> Map Var DDef0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
tyName' (DDef0
ddf { tyName :: Var
tyName = Var
tyName', tyArgs :: [TyVar]
tyArgs = [], dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons = [([Char], [(IsBoxed, Ty0)])]
dataCons' })  Map Var DDef0
ddefs1
            mono_st' :: MonoState
mono_st'  = MonoState
mono_st { mono_dcons :: Map ([Char], [Ty0]) Var
mono_dcons = [(([Char], [Ty0]), Var)] -> Map ([Char], [Ty0]) Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(([Char], [Ty0]), Var)]
rst }
        MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st'
        Map Var DDef0 -> MonoM (Map Var DDef0)
monoDDefs Map Var DDef0
ddefs1'

    -- See examples/T127. Bar is monomorphic, but uses a monomorphized-by-hand
    -- Foo. We must update Bar to use the correct Foo.
    monoOblsDDef :: DDefs0 -> DDef0 -> MonoM DDef0
    monoOblsDDef :: Map Var DDef0 -> DDef0 -> StateT MonoState PassM DDef0
monoOblsDDef Map Var DDef0
ddefs1 d :: DDef0
d@DDef{[([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = do
      [([Char], [(IsBoxed, Ty0)])]
dataCons' <- (([Char], [(IsBoxed, Ty0)])
 -> StateT MonoState PassM ([Char], [(IsBoxed, Ty0)]))
-> [([Char], [(IsBoxed, Ty0)])]
-> StateT MonoState PassM [([Char], [(IsBoxed, Ty0)])]
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]
dcon, [(IsBoxed, Ty0)]
args) -> ([Char]
dcon,) ([(IsBoxed, Ty0)] -> ([Char], [(IsBoxed, Ty0)]))
-> StateT MonoState PassM [(IsBoxed, Ty0)]
-> StateT MonoState PassM ([Char], [(IsBoxed, Ty0)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((IsBoxed, Ty0) -> StateT MonoState PassM (IsBoxed, Ty0))
-> [(IsBoxed, Ty0)] -> StateT MonoState PassM [(IsBoxed, Ty0)]
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 (\(IsBoxed
a,Ty0
ty) -> (IsBoxed
a,) (Ty0 -> (IsBoxed, Ty0))
-> StateT MonoState PassM Ty0
-> StateT MonoState PassM (IsBoxed, Ty0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1 Ty0
ty) [(IsBoxed, Ty0)]
args) [([Char], [(IsBoxed, Ty0)])]
dataCons
      DDef0 -> StateT MonoState PassM DDef0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DDef0 -> StateT MonoState PassM DDef0)
-> DDef0 -> StateT MonoState PassM DDef0
forall a b. (a -> b) -> a -> b
$ DDef0
d{ dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons = [([Char], [(IsBoxed, Ty0)])]
dataCons' }


-- After 'monoLambdas' runs, (mono_lams MonoState) must be empty
assertLambdasMonomorphized :: (Monad m, HasCallStack) => MonoState -> m ()
assertLambdasMonomorphized :: forall (m :: * -> *). (Monad m, HasCallStack) => MonoState -> m ()
assertLambdasMonomorphized MonoState{Map (Var, [Ty0]) Var
mono_lams :: MonoState -> Map (Var, [Ty0]) Var
mono_lams :: Map (Var, [Ty0]) Var
mono_lams} =
  if Map (Var, [Ty0]) Var -> IsBoxed
forall k a. Map k a -> IsBoxed
M.null Map (Var, [Ty0]) Var
mono_lams
  then () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected 0 lambda monormorphization obligations. Got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Map (Var, [Ty0]) Var -> [Char]
forall a. Out a => a -> [Char]
sdoc Map (Var, [Ty0]) Var
mono_lams

assertSameLength :: (Out a, Out b, Monad m, HasCallStack) => String -> [a] -> [b] -> m ()
assertSameLength :: forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength [Char]
msg [a]
as [b]
bs =
  if [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
/= [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
bs
  then [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"assertSameLength: Type applications " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Out a => a -> [Char]
sdoc [b]
bs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" incompatible with the type variables: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
               [a] -> [Char]
forall a. Out a => a -> [Char]
sdoc [a]
as [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".\n " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
  else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


monoOblsTy :: DDefs0 -> Ty0 -> MonoM Ty0
monoOblsTy :: Map Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1 Ty0
t = do
  case Ty0
t of
    Ty0
CharTy    -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
IntTy     -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
FloatTy   -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
SymTy0    -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
BoolTy    -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    TyVar{}   -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    MetaTv{}  -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    ProdTy [Ty0]
ls -> [Ty0] -> Ty0
ProdTy ([Ty0] -> Ty0)
-> StateT MonoState PassM [Ty0] -> StateT MonoState PassM Ty0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1) [Ty0]
ls
    SymDictTy{}  -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    PDictTy{} -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    ArrowTy [Ty0]
as Ty0
b -> do
      [Ty0]
as' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1) [Ty0]
as
      Ty0
b' <- Map Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1 Ty0
b
      Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty0 -> StateT MonoState PassM Ty0)
-> Ty0 -> StateT MonoState PassM Ty0
forall a b. (a -> b) -> a -> b
$ [Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
as' Ty0
b'
    PackedTy [Char]
tycon [Ty0]
tyapps ->
      case [Ty0]
tyapps of
        [] -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
        -- We're only looking for fully monomorphized datatypes here
        [Ty0]
_  -> case [Ty0] -> [TyVar]
tyVarsInTys [Ty0]
tyapps of
                [] -> do
                  [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs1) [Ty0]
tyapps
                  MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
                  case ([Char], [Ty0]) -> Map ([Char], [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Char]
tycon, [Ty0]
tyapps') (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st) of
                    Maybe Var
Nothing -> do
                      let DDef{[TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs :: [TyVar]
tyArgs} = Map Var DDef0 -> [Char] -> DDef0
forall a. Out a => DDefs a -> [Char] -> DDef a
lookupDDef Map Var DDef0
ddefs1 [Char]
tycon
                      [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"In the type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
t) [TyVar]
tyArgs [Ty0]
tyapps'
                      Var
suffix <- PassM Var -> StateT MonoState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT MonoState PassM Var)
-> PassM Var -> StateT MonoState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"_v"
                      let mono_st' :: MonoState
mono_st' = ([Char], [Ty0]) -> Var -> MonoState -> MonoState
extendDatacons ([Char]
tycon, [Ty0]
tyapps') Var
suffix MonoState
mono_st
                          tycon' :: [Char]
tycon' = [Char]
tycon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Var -> [Char]
fromVar Var
suffix)
                      MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st'
                      Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty0 -> StateT MonoState PassM Ty0)
-> Ty0 -> StateT MonoState PassM Ty0
forall a b. (a -> b) -> a -> b
$ [Char] -> [Ty0] -> Ty0
PackedTy [Char]
tycon' []
                    Just Var
suffix -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty0 -> StateT MonoState PassM Ty0)
-> Ty0 -> StateT MonoState PassM Ty0
forall a b. (a -> b) -> a -> b
$ [Char] -> [Ty0] -> Ty0
PackedTy ([Char]
tycon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Var -> [Char]
fromVar Var
suffix)) []
                [TyVar]
_  -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    VectorTy{} -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    ListTy{} -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
ArenaTy  -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
SymSetTy -> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
SymHashTy-> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t
    Ty0
IntHashTy-> Ty0 -> StateT MonoState PassM Ty0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ty0
t


-- | Collect monomorphization obligations.
collectMonoObls :: DDefs0 -> Env2 Ty0 -> S.Set Var -> Exp0 -> MonoM Exp0
collectMonoObls :: Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel Exp0
ex =
  case Exp0
ex of
    AppE Var
f [] [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0]
args'
    AppE Var
f [Ty0]
tyapps [Exp0]
args -> do
      [Exp0]
args'   <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs) [Ty0]
tyapps
      Var
f' <- Var -> [Ty0] -> StateT MonoState PassM Var
addFnObl Var
f [Ty0]
tyapps'
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f' [] [Exp0]
args'
    LetE (Var
v, [], ty :: Ty0
ty@ArrowTy{}, Exp0
rhs) Exp0
bod ->do
      let env2' :: Env2 Ty0
env2' = (Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
ty Env2 Ty0
env2)
      case Exp0
rhs of
        Ext (LambdaE{}) -> do
          Exp0
rhs' <- Exp0 -> MonoM Exp0
go Exp0
rhs
          Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2' Set Var
toplevel Exp0
bod
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty0
ty,Exp0
rhs') Exp0
bod'
        Exp0
_ -> do
          -- Special case for lambda bindings passed in as function arguments:
          --
          -- 'v' is an ArrowTy, but not a lambda defn -- this let binding must
          -- be in a function body, and 'v' must be a lambda that's
          -- passed in as an argument. We don't want to monormorphize it here.
          -- It'll be handled when the the outer fn is processed.
          -- To ensure that (AppE v ...) stays the same, we add 'v' into
          -- mono_st s.t. it's new name would be same as it's old name.
          (MonoState -> ((), MonoState)) -> StateT MonoState PassM ()
forall a. (MonoState -> (a, MonoState)) -> StateT MonoState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\MonoState
st -> ((), (Var, [Ty0]) -> Var -> MonoState -> MonoState
extendLambdas (Var
v,[]) Var
v MonoState
st))
          Exp0
rhs' <- Exp0 -> MonoM Exp0
go Exp0
rhs
          Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2' Set Var
toplevel Exp0
bod
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [], Ty0
ty, Exp0
rhs') Exp0
bod'

    LetE (Var
v,[],Ty0
ty,Exp0
rhs) Exp0
bod -> do
      let env2' :: Env2 Ty0
env2' = (Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
ty Env2 Ty0
env2)
      Exp0
rhs' <- Exp0 -> MonoM Exp0
go Exp0
rhs
      Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2' Set Var
toplevel Exp0
bod
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty0
ty,Exp0
rhs') Exp0
bod'

    LetE (Var
_, (Ty0
_:[Ty0]
_), Ty0
_, Exp0
_) Exp0
_ -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: Let not monomorphized: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> do
      case Map Var DDef0 -> Env2 Ty0 -> Exp0 -> Ty0
recoverType Map Var DDef0
ddefs Env2 Ty0
env2 Exp0
scrt of
        PackedTy [Char]
tycon [Ty0]
tyapps -> do
          MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
          (Var
suffix, MonoState
mono_st'') <-
            case [Ty0]
tyapps of
              -- It's a monomorphic datatype.
              [] -> (Var, MonoState) -> StateT MonoState PassM (Var, MonoState)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
"", MonoState
mono_st)
              [Ty0]
_  -> do
                [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs) [Ty0]
tyapps
                case ([Char], [Ty0]) -> Map ([Char], [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Char]
tycon, [Ty0]
tyapps') (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st) of
                  Maybe Var
Nothing -> do
                    let DDef{[TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs :: [TyVar]
tyArgs} = Map Var DDef0 -> [Char] -> DDef0
forall a. Out a => DDefs a -> [Char] -> DDef a
lookupDDef Map Var DDef0
ddefs [Char]
tycon
                    [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"In the expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex) [TyVar]
tyArgs [Ty0]
tyapps'
                    Var
suffix <- PassM Var -> StateT MonoState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT MonoState PassM Var)
-> PassM Var -> StateT MonoState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"_v"
                    let mono_st' :: MonoState
mono_st' = ([Char], [Ty0]) -> Var -> MonoState -> MonoState
extendDatacons ([Char]
tycon, [Ty0]
tyapps') Var
suffix MonoState
mono_st
                    (Var, MonoState) -> StateT MonoState PassM (Var, MonoState)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
suffix, MonoState
mono_st')
                  Just Var
suffix -> (Var, MonoState) -> StateT MonoState PassM (Var, MonoState)
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
suffix, MonoState
mono_st)
          MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st''
          Exp0
scrt' <- Exp0 -> MonoM Exp0
go Exp0
scrt
          [([Char], [(Var, Ty0)], Exp0)]
brs' <-
            ([([Char], [(Var, Ty0)], Exp0)]
 -> ([Char], [(Var, Ty0)], Exp0)
 -> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)])
-> [([Char], [(Var, Ty0)], Exp0)]
-> [([Char], [(Var, Ty0)], Exp0)]
-> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
              (\[([Char], [(Var, Ty0)], Exp0)]
acc ([Char]
dcon,[(Var, Ty0)]
vtys,Exp0
bod) -> do
                let env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty0)]
vtys) Env2 Ty0
env2
                Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2' Set Var
toplevel Exp0
bod
                [([Char], [(Var, Ty0)], Exp0)]
-> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)]
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([Char], [(Var, Ty0)], Exp0)]
 -> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)])
-> [([Char], [(Var, Ty0)], Exp0)]
-> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ [([Char], [(Var, Ty0)], Exp0)]
acc [([Char], [(Var, Ty0)], Exp0)]
-> [([Char], [(Var, Ty0)], Exp0)] -> [([Char], [(Var, Ty0)], Exp0)]
forall a. [a] -> [a] -> [a]
++ [([Char]
dcon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
suffix,[(Var, Ty0)]
vtys,Exp0
bod')])
              [] [([Char], [(Var, Ty0)], Exp0)]
brs
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs'

        Ty0
ty -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: Unexpected type for the scrutinee, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
". In the expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    DataConE (ProdTy [Ty0]
tyapps) [Char]
dcon [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      case [Ty0]
tyapps of
        -- It's a monomorphic datatype.
        [] -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy []) [Char]
dcon [Exp0]
args'
        [Ty0]
_  -> do
          MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
          -- Collect datacon instances here.
          let tycon :: [Char]
tycon = Map Var DDef0 -> [Char] -> [Char]
forall a. Out a => DDefs a -> [Char] -> [Char]
getTyOfDataCon Map Var DDef0
ddefs [Char]
dcon
          [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs) [Ty0]
tyapps
          case ([Char], [Ty0]) -> Map ([Char], [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Char]
tycon, [Ty0]
tyapps') (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st) of
            Maybe Var
Nothing -> do
              let DDef{[TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs :: [TyVar]
tyArgs} = Map Var DDef0 -> [Char] -> DDef0
forall a. Out a => DDefs a -> [Char] -> DDef a
lookupDDef Map Var DDef0
ddefs [Char]
tycon
              [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"In the expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex) [TyVar]
tyArgs [Ty0]
tyapps'
              Var
suffix <- PassM Var -> StateT MonoState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT MonoState PassM Var)
-> PassM Var -> StateT MonoState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"_v"
              let mono_st' :: MonoState
mono_st' = ([Char], [Ty0]) -> Var -> MonoState -> MonoState
extendDatacons ([Char]
tycon, [Ty0]
tyapps) Var
suffix MonoState
mono_st
                  dcon' :: [Char]
dcon' = [Char]
dcon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Var -> [Char]
fromVar Var
suffix)
              MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st'
              Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy []) [Char]
dcon' [Exp0]
args'
            Just Var
suffix -> do
              let dcon' :: [Char]
dcon' = [Char]
dcon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Var -> [Char]
fromVar Var
suffix)
              Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy []) [Char]
dcon' [Exp0]
args'

    DataConE{} -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: DataConE expected ProdTy tyapps, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    PrimAppE Prim Ty0
pr [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr [Exp0]
args'

    -- Straightforward recursion
    VarE{}    -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitE{}    -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    CharE{}   -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    FloatE{}  -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitSymE{} -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    IfE Exp0
a Exp0
b Exp0
c -> do
      Exp0
a' <- Exp0 -> MonoM Exp0
go Exp0
a
      Exp0
b' <- Exp0 -> MonoM Exp0
go Exp0
b
      Exp0
c' <- Exp0 -> MonoM Exp0
go Exp0
c
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp0
a' Exp0
b' Exp0
c'
    MkProdE [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp0]
args'
    ProjE Int
i Exp0
e -> do
      Exp0
e' <- Exp0 -> MonoM Exp0
go Exp0
e
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp0
e'
    TimeIt Exp0
e Ty0
ty IsBoxed
b -> do
      Exp0
e' <- Exp0 -> MonoM Exp0
go Exp0
e
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
e' Ty0
ty IsBoxed
b
    WithArenaE Var
v Exp0
e -> do
      Exp0
e' <- Exp0 -> MonoM Exp0
go Exp0
e
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp0
e'
    Ext E0Ext Ty0 Ty0
ext ->
      case E0Ext Ty0 Ty0
ext of
        LambdaE [(Var, Ty0)]
args Exp0
bod -> do
          Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs (TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty0)]
args) Env2 Ty0
env2) Set Var
toplevel Exp0
bod
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
LambdaE [(Var, Ty0)]
args Exp0
bod'
        PolyAppE Exp0
op Exp0
arg -> do
          Exp0
op' <- Exp0 -> MonoM Exp0
go Exp0
op
          Exp0
arg' <- Exp0 -> MonoM Exp0
go Exp0
arg
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
PreExp E0Ext loc dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PolyAppE Exp0
op' Exp0
arg'
        FunRefE [Ty0]
tyapps Var
f ->
          case [Ty0]
tyapps of
            [] -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Ty0] -> Var -> E0Ext Ty0 Ty0
forall loc dec. [loc] -> Var -> E0Ext loc dec
FunRefE [] Var
f
            [Ty0]
_  -> do
              [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs) [Ty0]
tyapps
              Var
f' <- Var -> [Ty0] -> StateT MonoState PassM Var
addFnObl Var
f [Ty0]
tyapps'
              Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Ty0] -> Var -> E0Ext Ty0 Ty0
forall loc dec. [loc] -> Var -> E0Ext loc dec
FunRefE [] Var
f'
        BenchE Var
_fn [Ty0]
tyapps [Exp0]
_args IsBoxed
_b ->
          case [Ty0]
tyapps of
            [] -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
            [Ty0]
_  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: Polymorphic bench not supported yet. In: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
        ParE0 [Exp0]
ls -> do
          [Exp0]
ls' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
ls
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 [Exp0]
ls'
        PrintPacked Ty0
ty Exp0
arg -> do
          Exp0
arg' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel Exp0
arg
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty Exp0
arg'
        CopyPacked Ty0
ty Exp0
arg -> do
          Exp0
arg' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel Exp0
arg
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty Exp0
arg'
        TravPacked Ty0
ty Exp0
arg -> do
          Exp0
arg' <- Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel Exp0
arg
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty Exp0
arg'
        L Loc
p Exp0
e -> do
          Exp0
e' <- Exp0 -> MonoM Exp0
go Exp0
e
          Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p Exp0
e'
        LinearExt{} -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    SpawnE Var
f [] [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [] [Exp0]
args'
    SpawnE Var
f [Ty0]
tyapps [Exp0]
args -> do
      [Exp0]
args'   <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel) [Exp0]
args
      [Ty0]
tyapps' <- (Ty0 -> StateT MonoState PassM Ty0)
-> [Ty0] -> StateT MonoState PassM [Ty0]
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 Var DDef0 -> Ty0 -> StateT MonoState PassM Ty0
monoOblsTy Map Var DDef0
ddefs) [Ty0]
tyapps
      Var
f' <- Var -> [Ty0] -> StateT MonoState PassM Var
addFnObl Var
f [Ty0]
tyapps'
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f' [] [Exp0]
args'
    Exp0
SyncE    -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    MapE{}  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    FoldE{} -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"collectMonoObls: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
  where
    go :: Exp0 -> MonoM Exp0
go = Map Var DDef0 -> Env2 Ty0 -> Set Var -> Exp0 -> MonoM Exp0
collectMonoObls Map Var DDef0
ddefs Env2 Ty0
env2 Set Var
toplevel

    -- 'fn' Could be either a lambda, or toplevel
    addFnObl :: Var -> [Ty0] -> MonoM Var
    addFnObl :: Var -> [Ty0] -> StateT MonoState PassM Var
addFnObl Var
f [Ty0]
tyapps = do
      MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
      if Var
f Var -> Set Var -> IsBoxed
forall a. Ord a => a -> Set a -> IsBoxed
`S.member` Set Var
toplevel
      then case ((Var, [Ty0]) -> Map (Var, [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[Ty0]
tyapps) (MonoState -> Map (Var, [Ty0]) Var
mono_funs_done MonoState
mono_st), (Var, [Ty0]) -> Map (Var, [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[Ty0]
tyapps) (MonoState -> Map (Var, [Ty0]) Var
mono_funs_worklist MonoState
mono_st)) of
             (Maybe Var
Nothing, Maybe Var
Nothing) -> do
               Var
new_name <- PassM Var -> StateT MonoState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT MonoState PassM Var)
-> PassM Var -> StateT MonoState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
f
               (MonoState -> ((), MonoState)) -> StateT MonoState PassM ()
forall a. (MonoState -> (a, MonoState)) -> StateT MonoState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\MonoState
st -> ((), (Var, [Ty0]) -> Var -> MonoState -> MonoState
extendFuns (Var
f,[Ty0]
tyapps) Var
new_name MonoState
st))
               Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
new_name
             (Just Var
fn_name, Maybe Var
_) -> Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
fn_name
             (Maybe Var
_, Just Var
fn_name) -> Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
fn_name

      -- Why (f,[])? See "Special case for lambda bindings passed in as function arguments".
      else case ((Var, [Ty0]) -> Map (Var, [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[]) (MonoState -> Map (Var, [Ty0]) Var
mono_lams MonoState
mono_st), (Var, [Ty0]) -> Map (Var, [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[Ty0]
tyapps) (MonoState -> Map (Var, [Ty0]) Var
mono_lams MonoState
mono_st)) of
             (Maybe Var
Nothing, Maybe Var
Nothing) -> do
               Var
new_name <- PassM Var -> StateT MonoState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT MonoState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT MonoState PassM Var)
-> PassM Var -> StateT MonoState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
f
               (MonoState -> ((), MonoState)) -> StateT MonoState PassM ()
forall a. (MonoState -> (a, MonoState)) -> StateT MonoState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\MonoState
st -> ((),(Var, [Ty0]) -> Var -> MonoState -> MonoState
extendLambdas (Var
f,[Ty0]
tyapps) Var
new_name MonoState
st))
               Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
new_name
             (Maybe Var
_,Just Var
lam_name) -> Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
lam_name
             (Just Var
lam_name,Maybe Var
_) -> Var -> StateT MonoState PassM Var
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
lam_name


-- | Create monomorphic versions of lambdas bound in this expression.
-- This does not float out the lambda definitions.
monoLambdas :: Exp0 -> MonoM Exp0
-- Assummption: lambdas only appear as RHS in a let.
monoLambdas :: Exp0 -> MonoM Exp0
monoLambdas Exp0
ex =
  case Exp0
ex of
    LetE (Var
v,[],Ty0
vty, rhs :: Exp0
rhs@(Ext (LambdaE [(Var, Ty0)]
args Exp0
lam_bod))) Exp0
bod -> do
      MonoState
mono_st <- StateT MonoState PassM MonoState
forall s (m :: * -> *). MonadState s m => m s
get
      let lam_mono_st :: Map Var [Ty0]
lam_mono_st = Var -> MonoState -> Map Var [Ty0]
getLambdaObls Var
v MonoState
mono_st
      if Map Var [Ty0] -> IsBoxed
forall k a. Map k a -> IsBoxed
M.null Map Var [Ty0]
lam_mono_st
      -- This lambda is not polymorphic, don't monomorphize.
      then do
        Exp0
bod' <- Exp0 -> MonoM Exp0
go Exp0
bod
        Exp0
lam_bod' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
lam_bod
        Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [], Ty0
vty, (E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext ([(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
LambdaE [(Var, Ty0)]
args Exp0
lam_bod'))) Exp0
bod'
      -- Monomorphize and only bind those, drop the polymorphic defn.
      -- Also drop the obligation that we applied from MonoState.
      -- So after 'monoLambdas' is done, (mono_lams MonoState) should be [].
      else do
        -- new_lam_mono_st = old_lam_mono_st - applied_lam_mono_st
        let new_lam_mono_st :: Map (Var, [Ty0]) Var
new_lam_mono_st = (MonoState -> Map (Var, [Ty0]) Var
mono_lams MonoState
mono_st) Map (Var, [Ty0]) Var
-> Map (Var, [Ty0]) Var -> Map (Var, [Ty0]) Var
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
                              ([((Var, [Ty0]), Var)] -> Map (Var, [Ty0]) Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((Var, [Ty0]), Var)] -> Map (Var, [Ty0]) Var)
-> [((Var, [Ty0]), Var)] -> Map (Var, [Ty0]) Var
forall a b. (a -> b) -> a -> b
$ ((Var, [Ty0]) -> ((Var, [Ty0]), Var))
-> [(Var, [Ty0])] -> [((Var, [Ty0]), Var)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
w,[Ty0]
wtyapps) -> ((Var
v,[Ty0]
wtyapps), Var
w)) (Map Var [Ty0] -> [(Var, [Ty0])]
forall k a. Map k a -> [(k, a)]
M.toList Map Var [Ty0]
lam_mono_st))
            mono_st' :: MonoState
mono_st' = MonoState
mono_st { mono_lams :: Map (Var, [Ty0]) Var
mono_lams =  Map (Var, [Ty0]) Var
new_lam_mono_st }
        MonoState -> StateT MonoState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MonoState
mono_st'
        Exp0
bod' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
bod
        [(Var, [Ty0], Ty0, Exp0)]
monomorphized <- [(Var, [Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)]
monoLamBinds (Map Var [Ty0] -> [(Var, [Ty0])]
forall k a. Map k a -> [(k, a)]
M.toList Map Var [Ty0]
lam_mono_st) (Ty0
vty, Exp0
rhs)
        Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Exp0 -> (Var, [Ty0], Ty0, Exp0) -> Exp0)
-> Exp0 -> [(Var, [Ty0], Ty0, Exp0)] -> Exp0
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp0
acc (Var, [Ty0], Ty0, Exp0)
bind -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [Ty0], Ty0, Exp0)
bind Exp0
acc) Exp0
bod' [(Var, [Ty0], Ty0, Exp0)]
monomorphized

    LetE (Var
_,(Ty0
_:[Ty0]
_),Ty0
_,Exp0
_) Exp0
_ -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: Let not monomorphized: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    -- Straightforward recursion
    VarE{}    -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitE{}    -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    CharE{}   -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    FloatE{}  -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitSymE{} -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    AppE Var
f [Ty0]
tyapps [Exp0]
args ->
      case [Ty0]
tyapps of
        [] -> do [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
args
                 Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0]
args'
        [Ty0]
_  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: Expression probably not processed by collectMonoObls: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    PrimAppE Prim Ty0
pr [Exp0]
args -> do [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
args
                           Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr [Exp0]
args'
    LetE (Var
v,[],Ty0
ty,Exp0
rhs) Exp0
bod -> do
      Exp0
rhs' <- Exp0 -> MonoM Exp0
go Exp0
rhs
      Exp0
bod' <- Exp0 -> MonoM Exp0
monoLambdas Exp0
bod
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [], Ty0
ty, Exp0
rhs') Exp0
bod'
    IfE Exp0
a Exp0
b Exp0
c  -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> MonoM Exp0 -> StateT MonoState PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
go Exp0
a StateT MonoState PassM (Exp0 -> Exp0 -> Exp0)
-> MonoM Exp0 -> StateT MonoState PassM (Exp0 -> Exp0)
forall a b.
StateT MonoState PassM (a -> b)
-> StateT MonoState PassM a -> StateT MonoState PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> MonoM Exp0
go Exp0
b StateT MonoState PassM (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall a b.
StateT MonoState PassM (a -> b)
-> StateT MonoState PassM a -> StateT MonoState PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> MonoM Exp0
go Exp0
c
    MkProdE [Exp0]
ls -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0) -> StateT MonoState PassM [Exp0] -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
ls
    ProjE Int
i Exp0
a  -> (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
go Exp0
a
    CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> do
      Exp0
scrt' <- Exp0 -> MonoM Exp0
go Exp0
scrt
      [([Char], [(Var, Ty0)], Exp0)]
brs'  <- (([Char], [(Var, Ty0)], Exp0)
 -> StateT MonoState PassM ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)]
-> StateT MonoState PassM [([Char], [(Var, Ty0)], Exp0)]
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]
a,[(Var, Ty0)]
b,Exp0
c) -> ([Char]
a,[(Var, Ty0)]
b,) (Exp0 -> ([Char], [(Var, Ty0)], Exp0))
-> MonoM Exp0
-> StateT MonoState PassM ([Char], [(Var, Ty0)], Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
go Exp0
c) [([Char], [(Var, Ty0)], Exp0)]
brs
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs'
    DataConE Ty0
tyapp [Char]
dcon [Exp0]
args ->
      (Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
tyapp [Char]
dcon) ([Exp0] -> Exp0) -> StateT MonoState PassM [Exp0] -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
args
    TimeIt Exp0
e Ty0
ty IsBoxed
b  -> (\Exp0
e' -> Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
e' Ty0
ty IsBoxed
b) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
go Exp0
e
    WithArenaE Var
v Exp0
e -> (\Exp0
e' -> Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp0
e') (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
go Exp0
e
    Ext (LambdaE{})  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: Encountered a LambdaE outside a let binding. In\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    Ext (PolyAppE Exp0
op Exp0
args) -> do
      Exp0
op' <- Exp0 -> MonoM Exp0
go Exp0
op
      Exp0
args' <- Exp0 -> MonoM Exp0
go Exp0
args
      Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
PreExp E0Ext loc dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PolyAppE Exp0
op' Exp0
args'
    Ext (FunRefE{})  -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    Ext (BenchE{})   -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    Ext (ParE0 [Exp0]
ls)   -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0)
-> ([Exp0] -> E0Ext Ty0 Ty0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 ([Exp0] -> Exp0) -> StateT MonoState PassM [Exp0] -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
ls
    Ext (PrintPacked Ty0
ty Exp0
arg)-> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
monoLambdas Exp0
arg
    Ext (CopyPacked Ty0
ty Exp0
arg)-> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
monoLambdas Exp0
arg
    Ext (TravPacked Ty0
ty Exp0
arg)-> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
monoLambdas Exp0
arg
    Ext (L Loc
p Exp0
e)      -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p) (Exp0 -> Exp0) -> MonoM Exp0 -> MonoM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> MonoM Exp0
monoLambdas Exp0
e
    Ext (LinearExt{}) -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    SpawnE Var
f [Ty0]
tyapps [Exp0]
args ->
      case [Ty0]
tyapps of
        [] -> do [Exp0]
args' <- (Exp0 -> MonoM Exp0) -> [Exp0] -> StateT MonoState PassM [Exp0]
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 Exp0 -> MonoM Exp0
monoLambdas [Exp0]
args
                 Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> MonoM Exp0) -> Exp0 -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [] [Exp0]
args'
        [Ty0]
_  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: Expression probably not processed by collectMonoObls: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    Exp0
SyncE   -> Exp0 -> MonoM Exp0
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    MapE{}  -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    FoldE{} -> [Char] -> MonoM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> MonoM Exp0) -> [Char] -> MonoM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"monoLambdas: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
  where go :: Exp0 -> MonoM Exp0
go = Exp0 -> MonoM Exp0
monoLambdas

        monoLamBinds :: [(Var,[Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)]
        monoLamBinds :: [(Var, [Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)]
monoLamBinds [] (Ty0, Exp0)
_ = [(Var, [Ty0], Ty0, Exp0)] -> MonoM [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> StateT MonoState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        monoLamBinds ((Var
w, [Ty0]
tyapps):[(Var, [Ty0])]
rst) (Ty0
ty,Exp0
ex1) = do
          let tyvars :: [TyVar]
tyvars = Ty0 -> [TyVar]
tyVarsInTy Ty0
ty
          [Char] -> [TyVar] -> [Ty0] -> StateT MonoState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"In the expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex1) [TyVar]
tyvars [Ty0]
tyapps
          let mp :: Map TyVar Ty0
mp = [(TyVar, Ty0)] -> Map TyVar Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TyVar, Ty0)] -> Map TyVar Ty0)
-> [(TyVar, Ty0)] -> Map TyVar Ty0
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Ty0] -> [(TyVar, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tyvars [Ty0]
tyapps
              ty' :: Ty0
ty'  = Map TyVar Ty0 -> Ty0 -> Ty0
substTyVar Map TyVar Ty0
mp Ty0
ty
              ex' :: Exp0
ex'  = Map TyVar Ty0 -> Exp0 -> Exp0
substTyVarExp Map TyVar Ty0
mp Exp0
ex1
          ([(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [(Var
w, [], Ty0
ty', Exp0
ex')]) ([(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)])
-> MonoM [(Var, [Ty0], Ty0, Exp0)]
-> MonoM [(Var, [Ty0], Ty0, Exp0)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, [Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)]
monoLamBinds [(Var, [Ty0])]
rst (Ty0
ty,Exp0
ex1)


-- | Remove all polymorphic functions and datatypes from a program. 'monoLambdas'
-- already gets rid of polymorphic mono_lams.
purgePolyFuns :: Prog0 -> Prog0
purgePolyFuns :: Prog0 -> Prog0
purgePolyFuns p :: Prog0
p@Prog{FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp0
fundefs} =
  Prog0
p { fundefs :: FunDefs Exp0
fundefs = (FunDef0 -> IsBoxed) -> FunDefs Exp0 -> FunDefs Exp0
forall a k. (a -> IsBoxed) -> Map k a -> Map k a
M.filter FunDef0 -> IsBoxed
isMonoFun FunDefs Exp0
fundefs }

isMonoFun :: FunDef0 -> Bool
isMonoFun :: FunDef0 -> IsBoxed
isMonoFun FunDef{ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy} = (TyScheme -> [TyVar]
tyVarsFromScheme ArrowTy (TyOf Exp0)
TyScheme
funTy) [TyVar] -> [TyVar] -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== []

purgePolyDDefs :: Prog0 -> Prog0
purgePolyDDefs :: Prog0 -> Prog0
purgePolyDDefs p :: Prog0
p@Prog{DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs :: DDefs (TyOf Exp0)
ddefs} =
  Prog0
p { ddefs :: DDefs (TyOf Exp0)
ddefs = (DDef0 -> IsBoxed) -> Map Var DDef0 -> Map Var DDef0
forall a k. (a -> IsBoxed) -> Map k a -> Map k a
M.filter DDef0 -> IsBoxed
forall {a}. DDef a -> IsBoxed
isMonoDDef DDefs (TyOf Exp0)
Map Var DDef0
ddefs }
  where
    isMonoDDef :: DDef a -> IsBoxed
isMonoDDef DDef{[TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs :: [TyVar]
tyArgs} = [TyVar]
tyArgs [TyVar] -> [TyVar] -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== []

-- See Step (4) in the big note. Lot of code duplication :(
updateTyCons :: MonoState -> Prog0 -> Prog0
updateTyCons :: MonoState -> Prog0 -> Prog0
updateTyCons MonoState
mono_st p :: Prog0
p@Prog{DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs :: DDefs (TyOf Exp0)
ddefs, FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp0
fundefs,Maybe (Exp0, TyOf Exp0)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp}=
  let fundefs' :: FunDefs Exp0
fundefs' = (FunDef0 -> FunDef0) -> FunDefs Exp0 -> FunDefs Exp0
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FunDef0 -> FunDef0
fixFunDef FunDefs Exp0
fundefs
      mainExp' :: Maybe (Exp0, Ty0)
mainExp' = case Maybe (Exp0, TyOf Exp0)
mainExp of
                   Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
                   Just (Exp0
e,TyOf Exp0
ty) -> (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just (Map Var DDef0 -> MonoState -> Exp0 -> Exp0
updateTyConsExp DDefs (TyOf Exp0)
Map Var DDef0
ddefs MonoState
mono_st Exp0
e, Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy DDefs (TyOf Exp0)
Map Var DDef0
ddefs MonoState
mono_st TyOf Exp0
Ty0
ty)
  in Prog0
p { fundefs :: FunDefs Exp0
fundefs = FunDefs Exp0
fundefs', mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp = Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp' }
  where
    fixFunDef :: FunDef0 -> FunDef0
    fixFunDef :: FunDef0 -> FunDef0
fixFunDef fn :: FunDef0
fn@FunDef{ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy, Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} =
      let funTy' :: TyScheme
funTy' = [TyVar] -> Ty0 -> TyScheme
ForAll (TyScheme -> [TyVar]
tyVarsFromScheme ArrowTy (TyOf Exp0)
TyScheme
funTy) (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy DDefs (TyOf Exp0)
Map Var DDef0
ddefs MonoState
mono_st (TyScheme -> Ty0
tyFromScheme ArrowTy (TyOf Exp0)
TyScheme
funTy))
          funBody' :: Exp0
funBody' = Map Var DDef0 -> MonoState -> Exp0 -> Exp0
updateTyConsExp DDefs (TyOf Exp0)
Map Var DDef0
ddefs MonoState
mono_st Exp0
funBody
      in FunDef0
fn { funTy :: ArrowTy (TyOf Exp0)
funTy = ArrowTy (TyOf Exp0)
TyScheme
funTy', funBody :: Exp0
funBody = Exp0
funBody' }

-- |
updateTyConsExp :: DDefs0 ->  MonoState -> Exp0 -> Exp0
updateTyConsExp :: Map Var DDef0 -> MonoState -> Exp0 -> Exp0
updateTyConsExp Map Var DDef0
ddefs MonoState
mono_st Exp0
ex =
  case Exp0
ex of
    VarE{}    -> Exp0
ex
    LitE{}    -> Exp0
ex
    CharE{}   -> Exp0
ex
    FloatE{}  -> Exp0
ex
    LitSymE{} -> Exp0
ex
    AppE Var
f [Ty0]
tyapps [Exp0]
args    -> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Ty0]
tyapps ((Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
args)
    PrimAppE Prim Ty0
pr [Exp0]
args  -> Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr ((Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
args)
    LetE (Var
v,[Ty0]
tyapps,Ty0
ty,Exp0
rhs) Exp0
bod -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [Ty0]
tyapps, Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty, Exp0 -> Exp0
go Exp0
rhs) (Exp0 -> Exp0
go Exp0
bod)
    IfE Exp0
a Exp0
b Exp0
c  -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0
go Exp0
a) (Exp0 -> Exp0
go Exp0
b) (Exp0 -> Exp0
go Exp0
c)
    MkProdE [Exp0]
ls -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ((Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
ls)
    ProjE Int
i Exp0
e  -> Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp0 -> Exp0
go Exp0
e)
    CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs ->
      Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp0 -> Exp0
go Exp0
scrt) ((([Char], [(Var, Ty0)], Exp0) -> ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)] -> [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> [a] -> [b]
map
                        (\([Char]
dcon,[(Var, Ty0)]
vtys,Exp0
rhs) -> let ([Var]
vars,[Ty0]
tys) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
vtys
                                                 vtys' :: [(Var, Ty0)]
vtys' = [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars ([Ty0] -> [(Var, Ty0)]) -> [Ty0] -> [(Var, Ty0)]
forall a b. (a -> b) -> a -> b
$ (Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st) [Ty0]
tys
                                             in ([Char]
dcon, [(Var, Ty0)]
vtys', Exp0 -> Exp0
go Exp0
rhs))
                        [([Char], [(Var, Ty0)], Exp0)]
brs)
    DataConE (ProdTy [Ty0]
tyapps) [Char]
dcon [Exp0]
args ->
      let tyapps' :: [Ty0]
tyapps' = (Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st) [Ty0]
tyapps
          tycon :: [Char]
tycon   = Map Var DDef0 -> [Char] -> [Char]
forall a. Out a => DDefs a -> [Char] -> [Char]
getTyOfDataCon Map Var DDef0
ddefs [Char]
dcon
          dcon' :: [Char]
dcon' = case ([Char], [Ty0]) -> Map ([Char], [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Char]
tycon,[Ty0]
tyapps') (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st) of
                    Maybe Var
Nothing     -> [Char]
dcon
                    Just Var
suffix -> [Char]
dcon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
suffix
      in Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy [Ty0]
tyapps) [Char]
dcon' ((Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
args)
    DataConE{} -> [Char] -> Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp0) -> [Char] -> Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"updateTyConsExp: DataConE expected ProdTy tyapps, got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    TimeIt Exp0
e Ty0
ty IsBoxed
b -> Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt (Exp0 -> Exp0
go Exp0
e) (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty) IsBoxed
b
    WithArenaE Var
v Exp0
e -> Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (Exp0 -> Exp0
go Exp0
e)
    SpawnE Var
fn [Ty0]
tyapps [Exp0]
args -> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
fn [Ty0]
tyapps ((Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
args)
    Exp0
SyncE   -> Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    MapE{}  -> [Char] -> Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp0) -> [Char] -> Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"updateTyConsExp: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    FoldE{} -> [Char] -> Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp0) -> [Char] -> Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"updateTyConsExp: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    Ext (LambdaE [(Var, Ty0)]
args Exp0
bod) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext ([(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
LambdaE (((Var, Ty0) -> (Var, Ty0)) -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,Ty0
ty) -> (Var
v, Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty)) [(Var, Ty0)]
args) (Exp0 -> Exp0
go Exp0
bod))
    Ext (PolyAppE Exp0
a Exp0
b) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Exp0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
PreExp E0Ext loc dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PolyAppE (Exp0 -> Exp0
go Exp0
a) (Exp0 -> Exp0
go Exp0
b))
    Ext (FunRefE{})    -> Exp0
ex
    Ext (BenchE{})     -> Exp0
ex
    Ext (ParE0 [Exp0]
ls)     -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 ([Exp0] -> E0Ext Ty0 Ty0) -> [Exp0] -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ (Exp0 -> Exp0) -> [Exp0] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Exp0 -> Exp0
go [Exp0]
ls
    Ext (PrintPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty) (Exp0 -> Exp0
go Exp0
arg)
    Ext (CopyPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty) (Exp0 -> Exp0
go Exp0
arg)
    Ext (TravPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked (Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty) (Exp0 -> Exp0
go Exp0
arg)
    Ext (L Loc
p Exp0
e)        -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p (Exp0 -> Exp0
go Exp0
e)
    Ext (LinearExt{})  -> [Char] -> Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp0) -> [Char] -> Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"updateTyConsExp: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
  where
    go :: Exp0 -> Exp0
go = Map Var DDef0 -> MonoState -> Exp0 -> Exp0
updateTyConsExp Map Var DDef0
ddefs MonoState
mono_st

-- | Update TyCons if an appropriate monomorphization obligation exists.
updateTyConsTy :: DDefs0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy :: Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st Ty0
ty =
  case Ty0
ty of
    Ty0
CharTy  -> Ty0
ty
    Ty0
IntTy   -> Ty0
ty
    Ty0
FloatTy -> Ty0
ty
    Ty0
SymTy0  -> Ty0
ty
    Ty0
BoolTy  -> Ty0
ty
    TyVar{} ->  Ty0
ty
    MetaTv{} -> Ty0
ty
    ProdTy [Ty0]
tys  -> [Ty0] -> Ty0
ProdTy ((Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map Ty0 -> Ty0
go [Ty0]
tys)
    SymDictTy Maybe Var
v Ty0
t -> Maybe Var -> Ty0 -> Ty0
SymDictTy Maybe Var
v (Ty0 -> Ty0
go Ty0
t)
    PDictTy Ty0
k Ty0
v -> Ty0 -> Ty0 -> Ty0
PDictTy (Ty0 -> Ty0
go Ty0
k) (Ty0 -> Ty0
go Ty0
v)
    ArrowTy [Ty0]
as Ty0
b   -> [Ty0] -> Ty0 -> Ty0
ArrowTy ((Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map Ty0 -> Ty0
go [Ty0]
as) (Ty0 -> Ty0
go Ty0
b)
    PackedTy [Char]
t [Ty0]
tys ->
      let tys' :: [Ty0]
tys' = (Ty0 -> Ty0) -> [Ty0] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map Ty0 -> Ty0
go [Ty0]
tys
      in case ([Char], [Ty0]) -> Map ([Char], [Ty0]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Char]
t,[Ty0]
tys') (MonoState -> Map ([Char], [Ty0]) Var
mono_dcons MonoState
mono_st) of
           Maybe Var
Nothing     -> [Char] -> [Ty0] -> Ty0
PackedTy [Char]
t [Ty0]
tys'
           -- Why [] ? The type arguments aren't required as the DDef is monomorphic.
           Just Var
suffix -> [Char] -> [Ty0] -> Ty0
PackedTy ([Char]
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
fromVar Var
suffix) []
    VectorTy Ty0
t -> Ty0 -> Ty0
VectorTy (Ty0 -> Ty0
go Ty0
t)
    ListTy Ty0
t -> Ty0 -> Ty0
ListTy (Ty0 -> Ty0
go Ty0
t)
    Ty0
ArenaTy -> Ty0
ty
    Ty0
SymSetTy -> Ty0
ty
    Ty0
SymHashTy -> Ty0
ty
    Ty0
IntHashTy -> Ty0
ty
  where
    go :: Ty0 -> Ty0
go = Map Var DDef0 -> MonoState -> Ty0 -> Ty0
updateTyConsTy Map Var DDef0
ddefs MonoState
mono_st

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

-- The specialization monad.
type SpecM a = StateT SpecState PassM a

type FunRef = Var

data SpecState = SpecState
  { SpecState -> Map (Var, [Var]) Var
sp_funs_worklist :: M.Map (Var, [FunRef]) Var
  , SpecState -> Map (Var, [Var]) Var
sp_funs_done :: M.Map (Var, [FunRef]) Var
  , SpecState -> Map Var [(Var, Ty0)]
sp_extra_args :: M.Map Var [(Var, Ty0)]
  , SpecState -> FunDefs Exp0
sp_fundefs   :: FunDefs0 }
  deriving (Int -> SpecState -> [Char] -> [Char]
[SpecState] -> [Char] -> [Char]
SpecState -> [Char]
(Int -> SpecState -> [Char] -> [Char])
-> (SpecState -> [Char])
-> ([SpecState] -> [Char] -> [Char])
-> Show SpecState
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> SpecState -> [Char] -> [Char]
showsPrec :: Int -> SpecState -> [Char] -> [Char]
$cshow :: SpecState -> [Char]
show :: SpecState -> [Char]
$cshowList :: [SpecState] -> [Char] -> [Char]
showList :: [SpecState] -> [Char] -> [Char]
Show, SpecState -> SpecState -> IsBoxed
(SpecState -> SpecState -> IsBoxed)
-> (SpecState -> SpecState -> IsBoxed) -> Eq SpecState
forall a. (a -> a -> IsBoxed) -> (a -> a -> IsBoxed) -> Eq a
$c== :: SpecState -> SpecState -> IsBoxed
== :: SpecState -> SpecState -> IsBoxed
$c/= :: SpecState -> SpecState -> IsBoxed
/= :: SpecState -> SpecState -> IsBoxed
Eq, (forall x. SpecState -> Rep SpecState x)
-> (forall x. Rep SpecState x -> SpecState) -> Generic SpecState
forall x. Rep SpecState x -> SpecState
forall x. SpecState -> Rep SpecState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SpecState -> Rep SpecState x
from :: forall x. SpecState -> Rep SpecState x
$cto :: forall x. Rep SpecState x -> SpecState
to :: forall x. Rep SpecState x -> SpecState
Generic, Int -> SpecState -> Doc
[SpecState] -> Doc
SpecState -> Doc
(Int -> SpecState -> Doc)
-> (SpecState -> Doc) -> ([SpecState] -> Doc) -> Out SpecState
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> SpecState -> Doc
docPrec :: Int -> SpecState -> Doc
$cdoc :: SpecState -> Doc
doc :: SpecState -> Doc
$cdocList :: [SpecState] -> Doc
docList :: [SpecState] -> Doc
Out)

{-|

Specialization, only lambdas for now. E.g.

    foo :: (a -> b) -> a -> b
    foo f1 a = f1 a

    ... foo top1 x ...

becomes

    foo f1 a = ...

    foo2 :: a -> b
    foo2 a = top1 a

    ... foo2 x ...

-}
specLambdas :: Prog0 -> PassM Prog0
specLambdas :: Prog0 -> PassM Prog0
specLambdas prg :: Prog0
prg@Prog{DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs :: DDefs (TyOf Exp0)
ddefs,FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp0
fundefs,Maybe (Exp0, TyOf Exp0)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp} = do
  let spec_m :: StateT SpecState PassM (Maybe (Exp0, Ty0))
spec_m = do
        let env2 :: Env2 (TyOf Exp0)
env2 = Prog0 -> Env2 (TyOf Exp0)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog0
prg
        Maybe (Exp0, Ty0)
mainExp' <-
          case Maybe (Exp0, TyOf Exp0)
mainExp of
            Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp0, Ty0) -> StateT SpecState PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
            Just (Exp0
e, TyOf Exp0
ty) -> do
              Exp0
e' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp DDefs (TyOf Exp0)
Map Var DDef0
ddefs Env2 (TyOf Exp0)
Env2 Ty0
env2 Exp0
e
              Maybe (Exp0, Ty0) -> StateT SpecState PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Exp0, Ty0) -> StateT SpecState PassM (Maybe (Exp0, Ty0)))
-> Maybe (Exp0, Ty0) -> StateT SpecState PassM (Maybe (Exp0, Ty0))
forall a b. (a -> b) -> a -> b
$ (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just (Exp0
e', TyOf Exp0
Ty0
ty)
        -- Same reason as Step (1.2) in monomorphization.
        let fo_funs :: FunDefs Exp0
fo_funs = (FunDef0 -> IsBoxed) -> FunDefs Exp0 -> FunDefs Exp0
forall a k. (a -> IsBoxed) -> Map k a -> Map k a
M.filter FunDef0 -> IsBoxed
isFOFun FunDefs Exp0
fundefs
        (FunDef0 -> StateT SpecState PassM ())
-> [FunDef0] -> StateT SpecState PassM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          (\fn :: FunDef0
fn@FunDef{Var
funName :: forall ex. FunDef ex -> Var
funName :: Var
funName,[Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs,ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy,Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} -> do
                let venv :: TyEnv Ty0
venv = [(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy))
                    env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv TyEnv Ty0
venv Env2 (TyOf Exp0)
Env2 Ty0
env2
                Exp0
funBody' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp DDefs (TyOf Exp0)
Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
funBody
                SpecState
sp_state <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
                let funs :: FunDefs Exp0
funs   = SpecState -> FunDefs Exp0
sp_fundefs SpecState
sp_state
                    fn' :: FunDef0
fn'    = FunDef0
fn { funBody :: Exp0
funBody = Exp0
funBody' }
                    funs' :: FunDefs Exp0
funs'  = Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
funName FunDef0
fn' FunDefs Exp0
funs
                    sp_state' :: SpecState
sp_state' = SpecState
sp_state { sp_fundefs :: FunDefs Exp0
sp_fundefs = FunDefs Exp0
funs' }
                SpecState -> StateT SpecState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SpecState
sp_state'
                () -> StateT SpecState PassM ()
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          (FunDefs Exp0 -> [FunDef0]
forall k a. Map k a -> [a]
M.elems FunDefs Exp0
fo_funs)
        StateT SpecState PassM ()
fixpoint
        Maybe (Exp0, Ty0) -> StateT SpecState PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
mainExp'

  (Maybe (Exp0, Ty0)
mainExp',SpecState
sp_state'') <- StateT SpecState PassM (Maybe (Exp0, Ty0))
-> SpecState -> PassM (Maybe (Exp0, Ty0), SpecState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT SpecState PassM (Maybe (Exp0, Ty0))
spec_m SpecState
emptySpecState
  -- Get rid of all higher order functions.
  let fundefs' :: FunDefs Exp0
fundefs' = FunDefs Exp0 -> FunDefs Exp0
purgeHO (SpecState -> FunDefs Exp0
sp_fundefs SpecState
sp_state'')
      prg' :: Prog0
prg' = Prog0
prg {mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp = Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp', fundefs :: FunDefs Exp0
fundefs = FunDefs Exp0
fundefs'}

-- Typecheck again.
  Prog0 -> PassM Prog0
tcProg Prog0
prg'
  where
    emptySpecState :: SpecState
    emptySpecState :: SpecState
emptySpecState = Map (Var, [Var]) Var
-> Map (Var, [Var]) Var
-> Map Var [(Var, Ty0)]
-> FunDefs Exp0
-> SpecState
SpecState Map (Var, [Var]) Var
forall k a. Map k a
M.empty Map (Var, [Var]) Var
forall k a. Map k a
M.empty Map Var [(Var, Ty0)]
forall k a. Map k a
M.empty FunDefs Exp0
fundefs

    -- Lower functions
    fixpoint :: SpecM ()
    fixpoint :: StateT SpecState PassM ()
fixpoint = do
      SpecState
sp_state <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
      if Map (Var, [Var]) Var -> IsBoxed
forall k a. Map k a -> IsBoxed
M.null (SpecState -> Map (Var, [Var]) Var
sp_funs_worklist SpecState
sp_state)
      then () -> StateT SpecState PassM ()
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else do
        let fns :: FunDefs Exp0
fns = SpecState -> FunDefs Exp0
sp_fundefs SpecState
sp_state
            fn :: FunDef0
fn = FunDefs Exp0
fns FunDefs Exp0 -> Var -> FunDef0
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
fn_name
            ((Var
fn_name, [Var]
refs), Var
new_fn_name) = Int -> Map (Var, [Var]) Var -> ((Var, [Var]), Var)
forall k a. Int -> Map k a -> (k, a)
M.elemAt Int
0 (SpecState -> Map (Var, [Var]) Var
sp_funs_worklist SpecState
sp_state)
        Map Var DDef0
-> Var -> [Var] -> FunDef0 -> StateT SpecState PassM ()
specLambdasFun DDefs (TyOf Exp0)
Map Var DDef0
ddefs Var
new_fn_name [Var]
refs FunDef0
fn
        (SpecState -> ((), SpecState)) -> StateT SpecState PassM ()
forall a. (SpecState -> (a, SpecState)) -> StateT SpecState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\SpecState
st -> ((), SpecState
st { sp_funs_worklist :: Map (Var, [Var]) Var
sp_funs_worklist = (Var, [Var]) -> Map (Var, [Var]) Var -> Map (Var, [Var]) Var
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Var
fn_name, [Var]
refs) (SpecState -> Map (Var, [Var]) Var
sp_funs_worklist SpecState
st)
                              , sp_funs_done :: Map (Var, [Var]) Var
sp_funs_done = (Var, [Var]) -> Var -> Map (Var, [Var]) Var -> Map (Var, [Var]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fn_name, [Var]
refs) Var
new_fn_name (SpecState -> Map (Var, [Var]) Var
sp_funs_done SpecState
st) }))
        StateT SpecState PassM ()
fixpoint

    purgeHO :: FunDefs0 -> FunDefs0
    purgeHO :: FunDefs Exp0 -> FunDefs Exp0
purgeHO FunDefs Exp0
fns = (FunDef0 -> IsBoxed) -> FunDefs Exp0 -> FunDefs Exp0
forall a k. (a -> IsBoxed) -> Map k a -> Map k a
M.filter FunDef0 -> IsBoxed
isFOFun FunDefs Exp0
fns

    isFOFun :: FunDef0 -> Bool
    isFOFun :: FunDef0 -> IsBoxed
isFOFun FunDef{ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy} =
      let ForAll [TyVar]
_ (ArrowTy [Ty0]
arg_tys Ty0
ret_ty) = ArrowTy (TyOf Exp0)
funTy
      in (Ty0 -> IsBoxed) -> [Ty0] -> IsBoxed
forall (t :: * -> *) a.
Foldable t =>
(a -> IsBoxed) -> t a -> IsBoxed
all ([Ty0] -> IsBoxed
forall a. [a] -> IsBoxed
forall (t :: * -> *) a. Foldable t => t a -> IsBoxed
null ([Ty0] -> IsBoxed) -> (Ty0 -> [Ty0]) -> Ty0 -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty0 -> [Ty0]
arrowTysInTy) [Ty0]
arg_tys IsBoxed -> IsBoxed -> IsBoxed
&&
         Ty0 -> [Ty0]
arrowTysInTy Ty0
ret_ty [Ty0] -> [Ty0] -> IsBoxed
forall a. Eq a => a -> a -> IsBoxed
== []

-- Eliminate all functions passed in as arguments to this function.
specLambdasFun :: DDefs0 -> Var -> [FunRef] -> FunDef0 -> SpecM ()
specLambdasFun :: Map Var DDef0
-> Var -> [Var] -> FunDef0 -> StateT SpecState PassM ()
specLambdasFun Map Var DDef0
ddefs Var
new_fn_name [Var]
refs fn :: FunDef0
fn@FunDef{[Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs, ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy} = do
  SpecState
sp_state <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
  let
      -- lamda args
      funArgs' :: [Var]
funArgs'  = ((Var, Ty0) -> Var) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty0) -> Var
forall a b. (a, b) -> a
fst ([(Var, Ty0)] -> [Var]) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> a -> b
$ ((Var, Ty0) -> IsBoxed) -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. (a -> IsBoxed) -> [a] -> [a]
filter (Ty0 -> IsBoxed
isFunTy (Ty0 -> IsBoxed) -> ((Var, Ty0) -> Ty0) -> (Var, Ty0) -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, Ty0) -> Ty0
forall a b. (a, b) -> b
snd) ([(Var, Ty0)] -> [(Var, Ty0)]) -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy)
      specs :: [(Var, Var)]
specs     = [Var] -> [Var] -> [(Var, Var)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Var]
funArgs' [Var]
refs
      -- non-lambda args
      funArgs'' :: [Var]
funArgs'' = ((Var, Ty0) -> Var) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty0) -> Var
forall a b. (a, b) -> a
fst ([(Var, Ty0)] -> [Var]) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> a -> b
$ ((Var, Ty0) -> IsBoxed) -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. (a -> IsBoxed) -> [a] -> [a]
filter (IsBoxed -> IsBoxed
not (IsBoxed -> IsBoxed)
-> ((Var, Ty0) -> IsBoxed) -> (Var, Ty0) -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty0 -> IsBoxed
isFunTy (Ty0 -> IsBoxed) -> ((Var, Ty0) -> Ty0) -> (Var, Ty0) -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, Ty0) -> Ty0
forall a b. (a, b) -> b
snd) ([(Var, Ty0)] -> [(Var, Ty0)]) -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy)
      fn' :: FunDef0
fn' = FunDef0
fn { funName :: Var
funName = Var
new_fn_name
               , funBody :: Exp0
funBody = [(Var, Var)] -> Exp0 -> Exp0
do_spec [(Var, Var)]
specs (FunDef0 -> Exp0
forall ex. FunDef ex -> ex
funBody FunDef0
fn) }
  let venv :: TyEnv Ty0
venv = [(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Var]
funArgs'' (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy Ty0
TyScheme
funTy'))
      env2 :: Env2 Ty0
env2 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 TyEnv Ty0
venv (FunDefs Exp0 -> TyEnv (ArrowTy (TyOf Exp0))
forall a. FunDefs a -> TyEnv (ArrowTy (TyOf a))
initFunEnv (SpecState -> FunDefs Exp0
sp_fundefs SpecState
sp_state))
  Exp0
funBody' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2 (FunDef0 -> Exp0
forall ex. FunDef ex -> ex
funBody FunDef0
fn')
  SpecState
sp_state' <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
  let ([Var]
funArgs''', TyScheme
funTy'') =
        case Var -> Map Var [(Var, Ty0)] -> Maybe [(Var, Ty0)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
new_fn_name (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state') of
          Maybe [(Var, Ty0)]
Nothing -> ([Var]
funArgs'', TyScheme
funTy')
          Just [(Var, Ty0)]
extra_args ->
            let ForAll [TyVar]
tyvars1 (ArrowTy [Ty0]
arg_tys1 Ty0
ret_ty1) = TyScheme
funTy'
                ([Var]
extra_vars, [Ty0]
extra_tys) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
extra_args
             in ( [Var]
funArgs'' [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
extra_vars
                , [TyVar] -> Ty0 -> TyScheme
ForAll [TyVar]
tyvars1 ([Ty0] -> Ty0 -> Ty0
ArrowTy ([Ty0]
arg_tys1 [Ty0] -> [Ty0] -> [Ty0]
forall a. [a] -> [a] -> [a]
++ [Ty0]
extra_tys) Ty0
ret_ty1))
  let fn'' :: FunDef0
fn'' =
        FunDef0
fn'
          { funBody :: Exp0
funBody = Exp0
funBody'
          , funArgs :: [Var]
funArgs = [Var]
funArgs'''

-- N.B. Only update the type after 'specExp' runs.
          , funTy :: ArrowTy (TyOf Exp0)
funTy = ArrowTy (TyOf Exp0)
TyScheme
funTy''
          }
  (SpecState -> ((), SpecState)) -> StateT SpecState PassM ()
forall a. (SpecState -> (a, SpecState)) -> StateT SpecState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
    (\SpecState
st -> ((), SpecState
st {sp_fundefs :: FunDefs Exp0
sp_fundefs = Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
new_fn_name FunDef0
fn'' (SpecState -> FunDefs Exp0
sp_fundefs SpecState
st)}))
  where
    ForAll [TyVar]
tyvars (ArrowTy [Ty0]
arg_tys Ty0
ret_ty) = ArrowTy (TyOf Exp0)
funTy

-- TODO: What if the function returns another function ? Not handled yet.
    -- First order type
    funTy' :: TyScheme
funTy' = [TyVar] -> Ty0 -> TyScheme
ForAll [TyVar]
tyvars ([Ty0] -> Ty0 -> Ty0
ArrowTy ((Ty0 -> IsBoxed) -> [Ty0] -> [Ty0]
forall a. (a -> IsBoxed) -> [a] -> [a]
filter (IsBoxed -> IsBoxed
not (IsBoxed -> IsBoxed) -> (Ty0 -> IsBoxed) -> Ty0 -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty0 -> IsBoxed
isFunTy) [Ty0]
arg_tys) Ty0
ret_ty)

    do_spec :: [(Var,Var)] -> Exp0 -> Exp0
    do_spec :: [(Var, Var)] -> Exp0 -> Exp0
do_spec [(Var, Var)]
lams Exp0
e = ((Var, Var) -> Exp0 -> Exp0) -> Exp0 -> [(Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Var -> Var -> Exp0 -> Exp0) -> (Var, Var) -> Exp0 -> Exp0
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> Var -> Exp0 -> Exp0
forall {e}. Renamable e => Var -> Var -> e -> e
subst') Exp0
e [(Var, Var)]
lams

    subst' :: Var -> Var -> e -> e
subst' Var
old Var
new e
ex = Map Var Var -> e -> e
forall e. Renamable e => Map Var Var -> e -> e
gRename (Var -> Var -> Map Var Var
forall k a. k -> a -> Map k a
M.singleton Var
old Var
new) e
ex

specLambdasExp :: DDefs0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp :: Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2 Exp0
ex =
  case Exp0
ex of
    -- TODO, docs.
    AppE Var
f [] [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> SpecM Exp0) -> [Exp0] -> StateT SpecState PassM [Exp0]
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 Exp0 -> SpecM Exp0
go [Exp0]
args
      let args'' :: [Exp0]
args'' = Var -> Env2 Ty0 -> [Exp0] -> [Exp0]
dropFunRefs Var
f Env2 Ty0
env2 [Exp0]
args'
          refs :: [Var]
refs   = (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [] [Exp0]
args'
      SpecState
sp_state <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
      case [Var]
refs of
        [] ->
            case Var -> Map Var [(Var, Ty0)] -> Maybe [(Var, Ty0)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
f (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state) of
              Maybe [(Var, Ty0)]
Nothing -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0]
args''
              Just [(Var, Ty0)]
extra_args -> do
                  let ([Var]
vars,[Ty0]
_) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
extra_args
                      args''' :: [Exp0]
args''' = [Exp0]
args'' [Exp0] -> [Exp0] -> [Exp0]
forall a. [a] -> [a] -> [a]
++ (Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
vars
                  Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0]
args'''
        [Var]
_  -> do
          let extra_args :: [(Var, Ty0)]
extra_args = (Var -> [(Var, Ty0)] -> [(Var, Ty0)])
-> [(Var, Ty0)] -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Var
fnref [(Var, Ty0)]
acc ->
                                          case Var -> Map Var [(Var, Ty0)] -> Maybe [(Var, Ty0)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
fnref (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state) of
                                              Maybe [(Var, Ty0)]
Nothing    -> [(Var, Ty0)]
acc
                                              Just [(Var, Ty0)]
extra -> [(Var, Ty0)]
extra [(Var, Ty0)] -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. [a] -> [a] -> [a]
++ [(Var, Ty0)]
acc)
                                     [] [Var]
refs
          let ([Var]
vars,[Ty0]
_) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
extra_args
              args''' :: [Exp0]
args''' = [Exp0]
args'' [Exp0] -> [Exp0] -> [Exp0]
forall a. [a] -> [a] -> [a]
++ ((Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
vars)
          case ((Var, [Var]) -> Map (Var, [Var]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[Var]
refs) (SpecState -> Map (Var, [Var]) Var
sp_funs_done SpecState
sp_state), (Var, [Var]) -> Map (Var, [Var]) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
f,[Var]
refs) (SpecState -> Map (Var, [Var]) Var
sp_funs_worklist SpecState
sp_state)) of
            (Maybe Var
Nothing, Maybe Var
Nothing) -> do
              Var
f' <- PassM Var -> StateT SpecState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT SpecState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT SpecState PassM Var)
-> PassM Var -> StateT SpecState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
f
              let (ForAll [TyVar]
_ (ArrowTy [Ty0]
as Ty0
_)) = Var -> Env2 Ty0 -> ArrowTy Ty0
forall a. Out (ArrowTy a) => Var -> Env2 a -> ArrowTy a
lookupFEnv Var
f Env2 Ty0
env2
                  arrow_tys :: [Ty0]
arrow_tys = (Ty0 -> [Ty0]) -> [Ty0] -> [Ty0]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty0 -> [Ty0]
arrowTysInTy [Ty0]
as

-- Check that the # of refs we collected actually matches the #
              -- of functions 'f' expects.
              [Char] -> [Var] -> [Ty0] -> StateT SpecState PassM ()
forall a b (m :: * -> *).
(Out a, Out b, Monad m, HasCallStack) =>
[Char] -> [a] -> [b] -> m ()
assertSameLength ([Char]
"While lowering the expression " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex) [Var]
refs [Ty0]
arrow_tys
              -- We have a new lowering obligation.
              let sp_extra_args' :: Map Var [(Var, Ty0)]
sp_extra_args' = case [(Var, Ty0)]
extra_args of
                                     [] -> SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state
                                     [(Var, Ty0)]
_  -> Var -> [(Var, Ty0)] -> Map Var [(Var, Ty0)] -> Map Var [(Var, Ty0)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
f' [(Var, Ty0)]
extra_args (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state)
              let sp_state' :: SpecState
sp_state' = SpecState
sp_state { sp_funs_worklist :: Map (Var, [Var]) Var
sp_funs_worklist = (Var, [Var]) -> Var -> Map (Var, [Var]) Var -> Map (Var, [Var]) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
f,[Var]
refs) Var
f' (SpecState -> Map (Var, [Var]) Var
sp_funs_worklist SpecState
sp_state)
                                       , sp_extra_args :: Map Var [(Var, Ty0)]
sp_extra_args = Map Var [(Var, Ty0)]
sp_extra_args'
                                       }
              SpecState -> StateT SpecState PassM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SpecState
sp_state'
              Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f' [] [Exp0]
args'''
            (Just Var
f', Maybe Var
_) -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f' [] [Exp0]
args'''
            (Maybe Var
_, Just Var
f') -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f' [] [Exp0]
args'''
    AppE Var
_ (Ty0
_:[Ty0]
_) [Exp0]
_ -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: Call-site not monomorphized: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    -- Float out a lambda fun to the top-level.
    LetE (Var
v, [], Ty0
ty, (Ext (LambdaE [(Var, Ty0)]
args Exp0
lam_bod))) Exp0
bod -> do
      Var
v' <- PassM Var -> StateT SpecState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT SpecState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT SpecState PassM Var)
-> PassM Var -> StateT SpecState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
v
      let bod' :: Exp0
bod' = Map Var Var -> Exp0 -> Exp0
forall e. Renamable e => Map Var Var -> e -> e
gRename (Var -> Var -> Map Var Var
forall k a. k -> a -> Map k a
M.singleton Var
v Var
v') Exp0
bod
      SpecState
sp_state <- StateT SpecState PassM SpecState
forall s (m :: * -> *). MonadState s m => m s
get
      let arg_vars :: [Var]
arg_vars = ((Var, Ty0) -> Var) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty0) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty0)]
args
          captured_vars :: Set Var
captured_vars = Exp0 -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars Exp0
lam_bod Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
arg_vars)
                          Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` (FunDefs Exp0 -> Set Var
forall k a. Map k a -> Set k
M.keysSet (SpecState -> FunDefs Exp0
sp_fundefs SpecState
sp_state))
      Exp0
lam_bod' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs (TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
L1.extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty0)]
args) Env2 Ty0
env2) Exp0
lam_bod
      if IsBoxed -> IsBoxed
not (Set Var -> IsBoxed
forall a. Set a -> IsBoxed
S.null Set Var
captured_vars)
      -- Pass captured values as extra arguments
      then do
        let ls :: [Var]
ls = Set Var -> [Var]
forall a. Set a -> [a]
S.toList Set Var
captured_vars
            tys :: [Ty0]
tys = (Var -> Ty0) -> [Var] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
w -> case Var -> TyEnv Ty0 -> Maybe Ty0
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
w (Env2 Ty0 -> TyEnv Ty0
forall a. Env2 a -> TyEnv a
vEnv Env2 Ty0
env2) of
                               Maybe Ty0
Nothing -> [Char] -> Ty0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Ty0) -> [Char] -> Ty0
forall a b. (a -> b) -> a -> b
$ [Char]
"Unbound variable: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
forall e. Pretty e => e -> [Char]
pprender Var
w
                               Just Ty0
ty1 -> Ty0
ty1)
                      [Var]
ls
            fns :: [Var]
fns = Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
lam_bod []
            extra_args :: [(Var, Ty0)]
extra_args = (Var -> [(Var, Ty0)] -> [(Var, Ty0)])
-> [(Var, Ty0)] -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Var
fnref [(Var, Ty0)]
acc ->
                                          case Var -> Map Var [(Var, Ty0)] -> Maybe [(Var, Ty0)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
fnref (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state) of
                                              Maybe [(Var, Ty0)]
Nothing    -> [(Var, Ty0)]
acc
                                              Just [(Var, Ty0)]
extra -> [(Var, Ty0)]
extra [(Var, Ty0)] -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. [a] -> [a] -> [a]
++ [(Var, Ty0)]
acc)
                                     [] [Var]
fns
            extra_args1 :: [(Var, Ty0)]
extra_args1 = ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ls [Ty0]
tys) [(Var, Ty0)] -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. [a] -> [a] -> [a]
++ [(Var, Ty0)]
extra_args
            ([Var]
vars1,[Ty0]
tys1) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
extra_args1
            ty' :: TyScheme
ty' = [Ty0] -> TyScheme -> TyScheme
addArgsToTy [Ty0]
tys1 ([TyVar] -> Ty0 -> TyScheme
ForAll [] Ty0
ty)
            fn :: FunDef0
fn = FunDef { funName :: Var
funName = Var
v'
                        , funArgs :: [Var]
funArgs = [Var]
arg_vars [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
vars1
                        , funTy :: ArrowTy (TyOf Exp0)
funTy   = ArrowTy (TyOf Exp0)
TyScheme
ty'
                        , funBody :: Exp0
funBody = Exp0
lam_bod'
                        , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
NotRec
                                            , funInline :: FunInline
funInline = FunInline
Inline
                                            , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                            }
                        }
            env2' :: Env2 Ty0
env2' = Var -> ArrowTy Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> ArrowTy a -> Env2 a -> Env2 a
extendFEnv Var
v' ArrowTy Ty0
TyScheme
ty' Env2 Ty0
env2
        (SpecState -> ((), SpecState)) -> StateT SpecState PassM ()
forall a. (SpecState -> (a, SpecState)) -> StateT SpecState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\SpecState
st -> ((), SpecState
st { sp_fundefs :: FunDefs Exp0
sp_fundefs = Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v' FunDef0
fn (SpecState -> FunDefs Exp0
sp_fundefs SpecState
st)
                              , sp_extra_args :: Map Var [(Var, Ty0)]
sp_extra_args = Var -> [(Var, Ty0)] -> Map Var [(Var, Ty0)] -> Map Var [(Var, Ty0)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v' [(Var, Ty0)]
extra_args1 (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
st)}))
        Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
bod'
      else do
        let fns :: [Var]
fns = Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
lam_bod []
        let extra_args :: [(Var, Ty0)]
extra_args = (Var -> [(Var, Ty0)] -> [(Var, Ty0)])
-> [(Var, Ty0)] -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Var
fnref [(Var, Ty0)]
acc ->
                                          case Var -> Map Var [(Var, Ty0)] -> Maybe [(Var, Ty0)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
fnref (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
sp_state) of
                                              Maybe [(Var, Ty0)]
Nothing    -> [(Var, Ty0)]
acc
                                              Just [(Var, Ty0)]
extra -> [(Var, Ty0)]
extra [(Var, Ty0)] -> [(Var, Ty0)] -> [(Var, Ty0)]
forall a. [a] -> [a] -> [a]
++ [(Var, Ty0)]
acc)
                                     [] [Var]
fns
        let ([Var]
vars,[Ty0]
tys) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
extra_args
            ty' :: TyScheme
ty' = [Ty0] -> TyScheme -> TyScheme
addArgsToTy [Ty0]
tys ([TyVar] -> Ty0 -> TyScheme
ForAll [] Ty0
ty)
        let fn :: FunDef0
fn = FunDef { funName :: Var
funName = Var
v'
                        , funArgs :: [Var]
funArgs = [Var]
arg_vars [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
vars
                        , funTy :: ArrowTy (TyOf Exp0)
funTy   = ArrowTy (TyOf Exp0)
TyScheme
ty'
                        , funBody :: Exp0
funBody = Exp0
lam_bod'
                        , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
NotRec
                                            , funInline :: FunInline
funInline = FunInline
Inline
                                            , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                            }
                        }
            env2' :: Env2 Ty0
env2' = Var -> ArrowTy Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> ArrowTy a -> Env2 a -> Env2 a
extendFEnv Var
v' ([TyVar] -> Ty0 -> TyScheme
ForAll [] Ty0
ty) Env2 Ty0
env2
        (SpecState -> ((), SpecState)) -> StateT SpecState PassM ()
forall a. (SpecState -> (a, SpecState)) -> StateT SpecState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\SpecState
st -> ((), SpecState
st { sp_fundefs :: FunDefs Exp0
sp_fundefs = Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v' FunDef0
fn (SpecState -> FunDefs Exp0
sp_fundefs SpecState
st)
                              , sp_extra_args :: Map Var [(Var, Ty0)]
sp_extra_args = Var -> [(Var, Ty0)] -> Map Var [(Var, Ty0)] -> Map Var [(Var, Ty0)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v' [(Var, Ty0)]
extra_args (SpecState -> Map Var [(Var, Ty0)]
sp_extra_args SpecState
st)}))
        Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
bod'

    LetE (Var
v, [], Ty0
ty, Exp0
rhs) Exp0
bod -> do
      let _fn_refs :: [Var]
_fn_refs = Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
rhs []
          env2' :: Env2 Ty0
env2' = (Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
ty Env2 Ty0
env2)
      Exp0
rhs' <- Exp0 -> SpecM Exp0
go Exp0
rhs
      Exp0
bod' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
bod
      Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [], Ty0
ty, Exp0
rhs') Exp0
bod'

    LetE (Var
_, (Ty0
_:[Ty0]
_),Ty0
_,Exp0
_) Exp0
_ -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specExp: Binding not monomorphized: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

    -- Straightforward recursion
    VarE{}    -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitE{}    -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    CharE{}   -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    FloatE{}  -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    LitSymE{} -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
    PrimAppE Prim Ty0
pr [Exp0]
args -> do
      [Exp0]
args' <- (Exp0 -> SpecM Exp0) -> [Exp0] -> StateT SpecState PassM [Exp0]
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 Exp0 -> SpecM Exp0
go [Exp0]
args
      Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr [Exp0]
args'
    IfE Exp0
a Exp0
b Exp0
c -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> SpecM Exp0 -> StateT SpecState PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
a StateT SpecState PassM (Exp0 -> Exp0 -> Exp0)
-> SpecM Exp0 -> StateT SpecState PassM (Exp0 -> Exp0)
forall a b.
StateT SpecState PassM (a -> b)
-> StateT SpecState PassM a -> StateT SpecState PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> SpecM Exp0
go Exp0
b StateT SpecState PassM (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall a b.
StateT SpecState PassM (a -> b)
-> StateT SpecState PassM a -> StateT SpecState PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> SpecM Exp0
go Exp0
c
    MkProdE [Exp0]
ls -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0) -> StateT SpecState PassM [Exp0] -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> SpecM Exp0) -> [Exp0] -> StateT SpecState PassM [Exp0]
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 Exp0 -> SpecM Exp0
go [Exp0]
ls
    ProjE Int
i Exp0
a -> (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i) (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
a
    CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> do
      Exp0
scrt' <- Exp0 -> SpecM Exp0
go Exp0
scrt
      [([Char], [(Var, Ty0)], Exp0)]
brs' <- (([Char], [(Var, Ty0)], Exp0)
 -> StateT SpecState PassM ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)]
-> StateT SpecState PassM [([Char], [(Var, Ty0)], Exp0)]
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]
dcon,[(Var, Ty0)]
vtys,Exp0
rhs) -> do
                  let env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty0)]
vtys) Env2 Ty0
env2
                  ([Char]
dcon,[(Var, Ty0)]
vtys,) (Exp0 -> ([Char], [(Var, Ty0)], Exp0))
-> SpecM Exp0
-> StateT SpecState PassM ([Char], [(Var, Ty0)], Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
rhs)
                [([Char], [(Var, Ty0)], Exp0)]
brs
      Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs'
    DataConE Ty0
tyapp [Char]
dcon [Exp0]
args -> (Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
tyapp [Char]
dcon) ([Exp0] -> Exp0) -> StateT SpecState PassM [Exp0] -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> SpecM Exp0) -> [Exp0] -> StateT SpecState PassM [Exp0]
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 Exp0 -> SpecM Exp0
go [Exp0]
args
    TimeIt Exp0
e Ty0
ty IsBoxed
b -> do
       Exp0
e' <- Exp0 -> SpecM Exp0
go Exp0
e
       Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
e' Ty0
ty IsBoxed
b
    WithArenaE Var
v Exp0
e -> do
       Exp0
e' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs (Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
ArenaTy Env2 Ty0
env2) Exp0
e
       Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp0
e'
    SpawnE Var
fn [Ty0]
tyapps [Exp0]
args -> do
      Exp0
e' <- Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2 (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fn [Ty0]
tyapps [Exp0]
args)
      case Exp0
e' of
        AppE Var
fn' [Ty0]
tyapps' [Exp0]
args' -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
fn' [Ty0]
tyapps' [Exp0]
args'
        Exp0
_ -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error [Char]
"specLambdasExp: SpawnE"
    Exp0
SyncE   -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    MapE{}  -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    FoldE{} -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
    Ext E0Ext Ty0 Ty0
ext ->
      case E0Ext Ty0 Ty0
ext of
        LambdaE{}  -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: Should reach a LambdaE. It should be floated out by the Let case." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
        PolyAppE{} -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
        FunRefE{}  -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        BenchE{}   -> Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        ParE0 [Exp0]
ls -> do
          let mk_fn :: Exp0 -> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, (PreExp E0Ext Ty0 Ty0))], Exp0)
              mk_fn :: Exp0 -> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
mk_fn Exp0
e0 = do
                let vars :: [Var]
vars = Set Var -> [Var]
forall a. Set a -> [a]
S.toList (Set Var -> [Var]) -> Set Var -> [Var]
forall a b. (a -> b) -> a -> b
$ Exp0 -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars Exp0
e0
                [Var]
args <- (Var -> StateT SpecState PassM Var)
-> [Var] -> StateT SpecState 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 (\Var
v -> PassM Var -> StateT SpecState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT SpecState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT SpecState PassM Var)
-> PassM Var -> StateT SpecState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
v) [Var]
vars
                let e0' :: Exp0
e0' = ((Var, Var) -> Exp0 -> Exp0) -> Exp0 -> [(Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Var
old,Var
new) Exp0
acc ->
                                  Var -> Exp0 -> Exp0 -> Exp0
forall e. Substitutable e => Var -> e -> e -> e
gSubst Var
old (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
new) Exp0
acc)
                                Exp0
e0
                                ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars [Var]
args)
                -- let bind args = vars before call_a
                Var
fnname <- PassM Var -> StateT SpecState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT SpecState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT SpecState PassM Var)
-> PassM Var -> StateT SpecState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"fn"
                let binds :: [(Var, [Ty0], Ty0, Exp0)]
binds  = ((Var, Var, Ty0) -> (Var, [Ty0], Ty0, Exp0))
-> [(Var, Var, Ty0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,Var
w,Ty0
ty) -> (Var
v,[],Ty0
ty,Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
w)) ([Var] -> [Var] -> [Ty0] -> [(Var, Var, Ty0)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Var]
args [Var]
vars [Ty0]
argtys)
                    retty :: Ty0
retty  = Map Var DDef0 -> Env2 Ty0 -> Exp0 -> Ty0
recoverType Map Var DDef0
ddefs Env2 Ty0
env2 Exp0
e0
                    argtys :: [Ty0]
argtys = (Var -> Ty0) -> [Var] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
v -> Var -> Env2 Ty0 -> Ty0
forall a. Out a => Var -> Env2 a -> a
lookupVEnv Var
v Env2 Ty0
env2) [Var]
vars
                    fn :: FunDef0
fn = FunDef { funName :: Var
funName = Var
fnname
                                , funArgs :: [Var]
funArgs = [Var]
args
                                , funTy :: ArrowTy (TyOf Exp0)
funTy   = [TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
argtys Ty0
retty)
                                , funBody :: Exp0
funBody = Exp0
e0'
                                , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
NotRec
                                                    , funInline :: FunInline
funInline = FunInline
NoInline
                                                    , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                                    }
                                }
                (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
-> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef0 -> Maybe FunDef0
forall a. a -> Maybe a
Just FunDef0
fn, [(Var, [Ty0], Ty0, Exp0)]
binds, Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fnname [] ((Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
args))
          let mb_insert :: Maybe (FunDef ex) -> Map Var (FunDef ex) -> Map Var (FunDef ex)
mb_insert Maybe (FunDef ex)
mb_fn Map Var (FunDef ex)
mp = case Maybe (FunDef ex)
mb_fn of
                                     Just FunDef ex
fn -> Var -> FunDef ex -> Map Var (FunDef ex) -> Map Var (FunDef ex)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDef ex -> Var
forall ex. FunDef ex -> Var
funName FunDef ex
fn) FunDef ex
fn Map Var (FunDef ex)
mp
                                     Maybe (FunDef ex)
Nothing -> Map Var (FunDef ex)
mp
          ([Maybe FunDef0]
mb_fns, [[(Var, [Ty0], Ty0, Exp0)]]
binds, [Exp0]
calls) <- [(Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([Maybe FunDef0], [[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([Maybe FunDef0], [[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> StateT
     SpecState PassM [(Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> StateT
     SpecState
     PassM
     ([Maybe FunDef0], [[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0]
-> StateT
     SpecState PassM [(Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)]
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 (\Exp0
a -> case Exp0
a of
                                                  AppE{} -> (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
-> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FunDef0
forall a. Maybe a
Nothing, [], Exp0
a)
                                                  Exp0
_ -> Exp0 -> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, Exp0)], Exp0)
mk_fn Exp0
a)
                                         [Exp0]
ls
          (SpecState -> ((), SpecState)) -> StateT SpecState PassM ()
forall a. (SpecState -> (a, SpecState)) -> StateT SpecState PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\SpecState
st -> ((), SpecState
st { sp_fundefs :: FunDefs Exp0
sp_fundefs = (Maybe FunDef0 -> FunDefs Exp0 -> FunDefs Exp0)
-> FunDefs Exp0 -> [Maybe FunDef0] -> FunDefs Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall {ex}.
Maybe (FunDef ex) -> Map Var (FunDef ex) -> Map Var (FunDef ex)
mb_insert (SpecState -> FunDefs Exp0
sp_fundefs SpecState
st) [Maybe FunDef0]
mb_fns }))
          Exp0 -> SpecM Exp0
forall a. a -> StateT SpecState PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> SpecM Exp0) -> Exp0 -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
binds) (E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 [Exp0]
calls)
        PrintPacked Ty0
ty Exp0
arg -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty) (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
arg
        CopyPacked Ty0
ty Exp0
arg -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty) (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
arg
        TravPacked Ty0
ty Exp0
arg -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty) (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
arg
        LinearExt{}  -> [Char] -> SpecM Exp0
forall a. HasCallStack => [Char] -> a
error ([Char] -> SpecM Exp0) -> [Char] -> SpecM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"specLambdasExp: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
        L Loc
p Exp0
e -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p) (Exp0 -> Exp0) -> SpecM Exp0 -> SpecM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> SpecM Exp0
go Exp0
e
  where
    go :: Exp0 -> SpecM Exp0
go = Map Var DDef0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0
specLambdasExp Map Var DDef0
ddefs Env2 Ty0
env2

    _isFunRef :: PreExp Any Any Any -> IsBoxed
_isFunRef PreExp Any Any Any
e =
      case PreExp Any Any Any
e of
        VarE Var
v -> Var -> Map Var TyScheme -> IsBoxed
forall k a. Ord k => k -> Map k a -> IsBoxed
M.member Var
v (Env2 Ty0 -> TyEnv (ArrowTy Ty0)
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 Ty0
env2)
        PreExp Any Any Any
_ -> IsBoxed
False

    -- fn_0 (fn_1, thing, fn_2) => fn_0 (thing)
    dropFunRefs :: Var -> Env2 Ty0 -> [Exp0] -> [Exp0]
    dropFunRefs :: Var -> Env2 Ty0 -> [Exp0] -> [Exp0]
dropFunRefs Var
fn_name Env2 Ty0
env21 [Exp0]
args =
      ((Exp0, Ty0) -> [Exp0] -> [Exp0])
-> [Exp0] -> [(Exp0, Ty0)] -> [Exp0]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Exp0
a,Ty0
t) [Exp0]
acc -> if Ty0 -> IsBoxed
isFunTy Ty0
t then [Exp0]
acc else Exp0
aExp0 -> [Exp0] -> [Exp0]
forall a. a -> [a] -> [a]
:[Exp0]
acc) [] ([Exp0] -> [Ty0] -> [(Exp0, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp0]
args [Ty0]
arg_tys)
      where
        ForAll [TyVar]
_ (ArrowTy [Ty0]
arg_tys Ty0
_) = Var -> Env2 Ty0 -> ArrowTy Ty0
forall a. Out (ArrowTy a) => Var -> Env2 a -> ArrowTy a
lookupFEnv Var
fn_name Env2 Ty0
env21

    collectFunRefs :: Exp0 -> [FunRef] -> [FunRef]
    collectFunRefs :: Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
e [Var]
acc =
      case Exp0
e of
        VarE{}    -> [Var]
acc
        LitE{}    -> [Var]
acc
        CharE{}   -> [Var]
acc
        FloatE{}  -> [Var]
acc
        LitSymE{} -> [Var]
acc
        AppE Var
_ [Ty0]
_ [Exp0]
args   -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
args
        PrimAppE Prim Ty0
_ [Exp0]
args -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
args
        LetE (Var
_,[Ty0]
_,Ty0
_, Exp0
rhs) Exp0
bod -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0
bod, Exp0
rhs]
        IfE Exp0
a Exp0
b Exp0
c  -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0
c, Exp0
b, Exp0
a]
        MkProdE [Exp0]
ls -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
ls
        ProjE Int
_ Exp0
a  -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
a [Var]
acc
        DataConE Ty0
_ [Char]
_ [Exp0]
ls -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
ls
        TimeIt Exp0
a Ty0
_ IsBoxed
_   -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
a [Var]
acc
        WithArenaE Var
_ Exp0
e1-> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
e1 [Var]
acc
        CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> (([Char], [(Var, Ty0)], Exp0) -> [Var] -> [Var])
-> [Var] -> [([Char], [(Var, Ty0)], Exp0)] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                            (\([Char]
_,[(Var, Ty0)]
_,Exp0
b) [Var]
acc2 -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
b [Var]
acc2)
                            (Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
scrt [Var]
acc)
                            [([Char], [(Var, Ty0)], Exp0)]
brs
        SpawnE Var
_ [Ty0]
_ [Exp0]
args -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
args
        Exp0
SyncE     -> [Var]
acc
        MapE{}  -> [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Char]
"collectFunRefs: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e
        FoldE{} -> [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Char]
"collectFunRefs: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e
        Ext E0Ext Ty0 Ty0
ext ->
          case E0Ext Ty0 Ty0
ext of
            LambdaE [(Var, Ty0)]
_ Exp0
bod       -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
bod [Var]
acc
            PolyAppE Exp0
rator Exp0
rand -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
rand (Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
rator [Var]
acc)
            FunRefE [Ty0]
_ Var
f         -> Var
f Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
acc
            BenchE{}            -> [Var]
acc
            ParE0 [Exp0]
ls            -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectFunRefs [Var]
acc [Exp0]
ls
            PrintPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
arg [Var]
acc
            CopyPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
arg [Var]
acc
            TravPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
arg [Var]
acc
            L Loc
_ Exp0
e1 -> Exp0 -> [Var] -> [Var]
collectFunRefs Exp0
e1 [Var]
acc
            LinearExt {} ->
              [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$
              [Char]
"collectFunRefs: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

-- Returns all functions used in an expression, both in AppE's and FunRefE's.
    collectAllFuns :: Exp0 -> [FunRef] -> [FunRef]
    collectAllFuns :: Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
e [Var]
acc =
      case Exp0
e of
        VarE{}    -> [Var]
acc
        LitE{}    -> [Var]
acc
        CharE{}   -> [Var]
acc
        FloatE{}  -> [Var]
acc
        LitSymE{} -> [Var]
acc
        AppE Var
f [Ty0]
_ [Exp0]
args   -> Var
f Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
args
        PrimAppE Prim Ty0
_ [Exp0]
args -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
args
        LetE (Var
_,[Ty0]
_,Ty0
_, Exp0
rhs) Exp0
bod -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0
bod, Exp0
rhs]
        IfE Exp0
a Exp0
b Exp0
c  -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0
c, Exp0
b, Exp0
a]
        MkProdE [Exp0]
ls -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
ls
        ProjE Int
_ Exp0
a  -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
a [Var]
acc
        DataConE Ty0
_ [Char]
_ [Exp0]
ls -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
ls
        TimeIt Exp0
a Ty0
_ IsBoxed
_   -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
a [Var]
acc
        WithArenaE Var
_ Exp0
e1-> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
e1 [Var]
acc
        CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> (([Char], [(Var, Ty0)], Exp0) -> [Var] -> [Var])
-> [Var] -> [([Char], [(Var, Ty0)], Exp0)] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                            (\([Char]
_,[(Var, Ty0)]
_,Exp0
b) [Var]
acc2 -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
b [Var]
acc2)
                            (Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
scrt [Var]
acc)
                            [([Char], [(Var, Ty0)], Exp0)]
brs
        SpawnE Var
_ [Ty0]
_ [Exp0]
args -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
args
        Exp0
SyncE     -> [Var]
acc
        MapE{}  -> [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Char]
"collectAllFuns: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e
        FoldE{} -> [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Char]
"collectAllFuns: TODO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e
        Ext E0Ext Ty0 Ty0
ext ->
          case E0Ext Ty0 Ty0
ext of
            LambdaE [(Var, Ty0)]
_ Exp0
bod       -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
bod [Var]
acc
            PolyAppE Exp0
rator Exp0
rand -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
rand (Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
rator [Var]
acc)
            FunRefE [Ty0]
_ Var
f         -> Var
f Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
acc
            BenchE{}            -> [Var]
acc
            ParE0 [Exp0]
ls            -> (Exp0 -> [Var] -> [Var]) -> [Var] -> [Exp0] -> [Var]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp0 -> [Var] -> [Var]
collectAllFuns [Var]
acc [Exp0]
ls
            PrintPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
arg [Var]
acc
            CopyPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
arg [Var]
acc
            TravPacked Ty0
_ty Exp0
arg -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
arg [Var]
acc
            L Loc
_ Exp0
e1              -> Exp0 -> [Var] -> [Var]
collectAllFuns Exp0
e1 [Var]
acc
            LinearExt{}         -> [Char] -> [Var]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Var]) -> [Char] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Char]
"collectAllFuns: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex

addArgsToTy :: [Ty0] -> TyScheme -> TyScheme
addArgsToTy :: [Ty0] -> TyScheme -> TyScheme
addArgsToTy [Ty0]
ls (ForAll [TyVar]
tyvars (ArrowTy [Ty0]
in_tys Ty0
ret_ty)) =
    let in_tys' :: [Ty0]
in_tys' = [Ty0]
in_tys [Ty0] -> [Ty0] -> [Ty0]
forall a. [a] -> [a] -> [a]
++ [Ty0]
ls
    in [TyVar] -> Ty0 -> TyScheme
ForAll [TyVar]
tyvars ([Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
in_tys' Ty0
ret_ty)
addArgsToTy [Ty0]
_ TyScheme
oth = [Char] -> TyScheme
forall a. HasCallStack => [Char] -> a
error ([Char] -> TyScheme) -> [Char] -> TyScheme
forall a b. (a -> b) -> a -> b
$ [Char]
"addArgsToTy: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TyScheme -> [Char]
forall a. Out a => a -> [Char]
sdoc TyScheme
oth [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not ArrowTy."



{-|

Let bind all anonymous lambdas.

    map (\x -> x + 1) [1,2,3]

becomes

   let lam_1 = (\x -> x + 1)
   in map lam_1 [1,2,3]

This is an intermediate step before the specializer turns the let bound
lambdas into top-level functions.

-}
bindLambdas :: Prog0 -> PassM Prog0
bindLambdas :: Prog0 -> PassM Prog0
bindLambdas prg :: Prog0
prg@Prog{FunDefs Exp0
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp0
fundefs,Maybe (Exp0, TyOf Exp0)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp} = do
  Maybe (Exp0, Ty0)
mainExp' <- case Maybe (Exp0, TyOf Exp0)
mainExp of
                Maybe (Exp0, TyOf Exp0)
Nothing      -> Maybe (Exp0, Ty0) -> PassM (Maybe (Exp0, Ty0))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
                Just (Exp0
a, TyOf Exp0
ty) -> (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just ((Exp0, Ty0) -> Maybe (Exp0, Ty0))
-> (Exp0 -> (Exp0, Ty0)) -> Exp0 -> Maybe (Exp0, Ty0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,TyOf Exp0
Ty0
ty) (Exp0 -> Maybe (Exp0, Ty0))
-> PassM Exp0 -> PassM (Maybe (Exp0, Ty0))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
goExp Exp0
a
  FunDefs Exp0
fundefs' <- (FunDef0 -> PassM FunDef0) -> FunDefs Exp0 -> PassM (FunDefs Exp0)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM
                (\fn :: FunDef0
fn@FunDef{Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} -> Exp0 -> PassM Exp0
goExp Exp0
funBody PassM Exp0 -> (Exp0 -> PassM FunDef0) -> PassM FunDef0
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                        \Exp0
b' -> FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef0
fn {funBody :: Exp0
funBody = Exp0
b'})
                FunDefs Exp0
fundefs
  Prog0 -> PassM Prog0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ Prog0
prg { fundefs :: FunDefs Exp0
fundefs = FunDefs Exp0
fundefs'
             , mainExp :: Maybe (Exp0, TyOf Exp0)
mainExp = Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp' }
  where
    goExp :: Exp0 -> PassM Exp0
    goExp :: Exp0 -> PassM Exp0
goExp Exp0
ex0 = Exp0 -> PassM Exp0
gocap Exp0
ex0
      where
      gocap :: Exp0 -> PassM Exp0
gocap Exp0
ex = do ([(Var, [Ty0], Ty0, Exp0)]
lets,Exp0
ex') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
ex
                    Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [Ty0], Ty0, Exp0)]
lets Exp0
ex'
      go :: Exp0 -> PassM ([(Var,[Ty0],Ty0,Exp0)], Exp0)
      go :: Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
e0 =
       case Exp0
e0 of
        (Ext (LambdaE{})) -> do
          Var
v  <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"lam"
          Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var
v,[],Ty0
ty,Exp0
e0)], Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)
        (LetE (Var
v,[Ty0]
tyapps,Ty0
t,rhs :: Exp0
rhs@(Ext LambdaE{})) Exp0
bod) -> do
            ([(Var, [Ty0], Ty0, Exp0)]
lts2, Exp0
bod') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
bod
            ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure  ([(Var, [Ty0], Ty0, Exp0)]
lts2, (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Ty0]
tyapps,Ty0
t,Exp0
rhs) Exp0
bod')
        -- boilerplate
        (Ext (ParE0 [Exp0]
ls)) -> do
          [Exp0]
ls' <- (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
gocap [Exp0]
ls
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 [Exp0]
ls')
        (Ext PolyAppE{}) -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (Ext FunRefE{})  -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (Ext BenchE{})   -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (Ext (PrintPacked Ty0
ty Exp0
arg)) -> do
          ([(Var, [Ty0], Ty0, Exp0)]
lts, Exp0
arg') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
lts, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty Exp0
arg'))
        (Ext (CopyPacked Ty0
ty Exp0
arg)) -> do
          ([(Var, [Ty0], Ty0, Exp0)]
lts, Exp0
arg') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
lts, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty Exp0
arg'))
        (Ext (TravPacked Ty0
ty Exp0
arg)) -> do
          ([(Var, [Ty0], Ty0, Exp0)]
lts, Exp0
arg') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
lts, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty Exp0
arg'))
        (Ext (L Loc
p Exp0
e1))     -> do
          ([(Var, [Ty0], Ty0, Exp0)]
ls, Exp0
e1') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
e1
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
ls, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p Exp0
e1')
        (Ext (LinearExt{})) -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a b. (a -> b) -> a -> b
$ [Char]
"bindLambdas: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e0
        (LitE Int
_)      -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (CharE Char
_)     -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (FloatE{})    -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (LitSymE Var
_)   -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (VarE Var
_)      -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (PrimAppE{})  -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        (AppE Var
f [Ty0]
tyapps [Exp0]
args) -> do
          ([[(Var, [Ty0], Ty0, Exp0)]]
ltss,[Exp0]
args') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
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 Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go [Exp0]
args
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
ltss, Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Ty0]
tyapps [Exp0]
args')
        (MapE (Var, Ty0, Exp0)
_ Exp0
_)    -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error [Char]
"bindLambdas: FINISHME MapE"
        (FoldE (Var, Ty0, Exp0)
_ (Var, Ty0, Exp0)
_ Exp0
_) -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error [Char]
"bindLambdas: FINISHME FoldE"
        (LetE (Var
v,[Ty0]
tyapps,Ty0
t,Exp0
rhs) Exp0
bod) -> do
           ([(Var, [Ty0], Ty0, Exp0)]
lts1, Exp0
rhs') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
rhs
           Exp0
bod' <- Exp0 -> PassM Exp0
gocap Exp0
bod
           ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure  ([(Var, [Ty0], Ty0, Exp0)]
lts1, (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Ty0]
tyapps,Ty0
t,Exp0
rhs') Exp0
bod')
        (IfE Exp0
e1 Exp0
e2 Exp0
e3) -> do
             ([(Var, [Ty0], Ty0, Exp0)]
lts1, Exp0
e1') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
e1
             Exp0
e2' <- Exp0 -> PassM Exp0
gocap Exp0
e2
             Exp0
e3' <- Exp0 -> PassM Exp0
gocap Exp0
e3
             ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure  ([(Var, [Ty0], Ty0, Exp0)]
lts1, Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp0
e1' Exp0
e2' Exp0
e3')
        (ProjE Int
i Exp0
e)  -> do ([(Var, [Ty0], Ty0, Exp0)]
lts,Exp0
e') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
e
                           ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure  ([(Var, [Ty0], Ty0, Exp0)]
lts, Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp0
e')
        (MkProdE [Exp0]
es) -> do ([[(Var, [Ty0], Ty0, Exp0)]]
ltss,[Exp0]
es') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
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 Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go [Exp0]
es
                           ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
ltss, [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp0]
es')
        (CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
ls) -> do ([(Var, [Ty0], Ty0, Exp0)]
lts,Exp0
scrt') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
scrt
                              [([Char], [(Var, Ty0)], Exp0)]
ls' <- (([Char], [(Var, Ty0)], Exp0)
 -> PassM ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)]
-> PassM [([Char], [(Var, Ty0)], Exp0)]
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]
a,[(Var, Ty0)]
b,Exp0
c) -> ([Char]
a,[(Var, Ty0)]
b,) (Exp0 -> ([Char], [(Var, Ty0)], Exp0))
-> PassM Exp0 -> PassM ([Char], [(Var, Ty0)], Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
gocap Exp0
c) [([Char], [(Var, Ty0)], Exp0)]
ls
                              ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
lts, Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
ls')
        (DataConE Ty0
c [Char]
loc [Exp0]
es) -> do ([[(Var, [Ty0], Ty0, Exp0)]]
ltss,[Exp0]
es') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
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 Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go [Exp0]
es
                                  ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
ltss, Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
c [Char]
loc [Exp0]
es')
        (SpawnE Var
f [Ty0]
tyapps [Exp0]
args) -> do
          ([[(Var, [Ty0], Ty0, Exp0)]]
ltss,[Exp0]
args') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
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 Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go [Exp0]
args
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
ltss, Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [Ty0]
tyapps [Exp0]
args')
        (Exp0
SyncE)    -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)
        (WithArenaE Var
v Exp0
e) -> do
          Exp0
e' <- (Exp0 -> PassM Exp0
gocap Exp0
e)
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp0
e')
        (TimeIt Exp0
e Ty0
t IsBoxed
b) -> do ([(Var, [Ty0], Ty0, Exp0)]
lts,Exp0
e') <- Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go Exp0
e
                             ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
lts, Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
e' Ty0
t IsBoxed
b)

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

-- | Desugar parallel tuples to spawn's and sync's, and printPacked into function calls.
desugarL0 :: Prog0 -> PassM Prog0
desugarL0 :: Prog0 -> PassM Prog0
desugarL0 (Prog DDefs (TyOf Exp0)
ddefs FunDefs Exp0
fundefs' Maybe (Exp0, TyOf Exp0)
mainExp') = do
  -- (Prog ddefs' fundefs' mainExp') <- addRepairFns prg
  let ddefs'' :: Map Var DDef0
ddefs'' = (DDef0 -> DDef0) -> Map Var DDef0 -> Map Var DDef0
forall a b k. (a -> b) -> Map k a -> Map k b
M.map DDef0 -> DDef0
desugar_tuples DDefs (TyOf Exp0)
Map Var DDef0
ddefs
  FunDefs Exp0
fundefs'' <- (FunDef0 -> PassM FunDef0) -> FunDefs Exp0 -> PassM (FunDefs Exp0)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM (\fn :: FunDef0
fn@FunDef{Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} -> Exp0 -> PassM Exp0
go Exp0
funBody PassM Exp0 -> (Exp0 -> PassM FunDef0) -> PassM FunDef0
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Exp0
b -> FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef0
fn {funBody :: Exp0
funBody = Exp0
b}) FunDefs Exp0
fundefs'
  Maybe (Exp0, Ty0)
mainExp'' <- case Maybe (Exp0, TyOf Exp0)
mainExp' of
                Maybe (Exp0, TyOf Exp0)
Nothing     -> Maybe (Exp0, Ty0) -> PassM (Maybe (Exp0, Ty0))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
                Just (Exp0
e,TyOf Exp0
ty) -> (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just ((Exp0, Ty0) -> Maybe (Exp0, Ty0))
-> (Exp0 -> (Exp0, Ty0)) -> Exp0 -> Maybe (Exp0, Ty0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,TyOf Exp0
Ty0
ty) (Exp0 -> Maybe (Exp0, Ty0))
-> PassM Exp0 -> PassM (Maybe (Exp0, Ty0))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
e
  Prog0 -> PassM Prog0
addRepairFns (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp0)
-> FunDefs Exp0 -> Maybe (Exp0, TyOf Exp0) -> Prog0
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp0)
Map Var DDef0
ddefs'' FunDefs Exp0
fundefs'' Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp''
  where
    err1 :: [Char] -> a
err1 [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"desugarL0: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg

    desugar_tuples :: DDef0 -> DDef0
    desugar_tuples :: DDef0 -> DDef0
desugar_tuples d :: DDef0
d@DDef{[([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} =
        let dataCons' :: [([Char], [(IsBoxed, Ty0)])]
dataCons' = (([Char], [(IsBoxed, Ty0)]) -> ([Char], [(IsBoxed, Ty0)]))
-> [([Char], [(IsBoxed, Ty0)])] -> [([Char], [(IsBoxed, Ty0)])]
forall a b. (a -> b) -> [a] -> [b]
map (([(IsBoxed, Ty0)] -> [(IsBoxed, Ty0)])
-> ([Char], [(IsBoxed, Ty0)]) -> ([Char], [(IsBoxed, Ty0)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((IsBoxed, Ty0) -> [(IsBoxed, Ty0)])
-> [(IsBoxed, Ty0)] -> [(IsBoxed, Ty0)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (IsBoxed, Ty0) -> [(IsBoxed, Ty0)]
forall t. (t, Ty0) -> [(t, Ty0)]
goty)) [([Char], [(IsBoxed, Ty0)])]
dataCons
        in DDef0
d { dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons = [([Char], [(IsBoxed, Ty0)])]
dataCons' }
      where
        goty :: (t, Ty0) -> [(t, Ty0)]
        goty :: forall t. (t, Ty0) -> [(t, Ty0)]
goty (t
isBoxed, Ty0
ty) =
          case Ty0
ty of
            ProdTy [Ty0]
ls -> (Ty0 -> [(t, Ty0)]) -> [Ty0] -> [(t, Ty0)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((t, Ty0) -> [(t, Ty0)]
forall t. (t, Ty0) -> [(t, Ty0)]
goty ((t, Ty0) -> [(t, Ty0)]) -> (Ty0 -> (t, Ty0)) -> Ty0 -> [(t, Ty0)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
isBoxed,)) [Ty0]
ls
            Ty0
_ -> [(t
isBoxed, Ty0
ty)]

    go :: Exp0 -> PassM Exp0
    go :: Exp0 -> PassM Exp0
go Exp0
ex =
      case Exp0
ex of
        VarE {} -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        LitE {} -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        CharE {} -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        FloatE {} -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        LitSymE {} -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        AppE Var
f [Ty0]
tyapps [Exp0]
args -> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Ty0]
tyapps ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
args
        PrimAppE Prim Ty0
pr [Exp0]
args -> do
          -- This is always going to have a function reference which
          -- we cannot eliminate.
          let args' :: [Exp0]
args' =
                case Prim Ty0
pr of
                  VSortP{} ->
                    case [Exp0]
args of
                      [Exp0
ls, Ext (FunRefE [Ty0]
_ Var
fp)]             -> [Exp0
ls, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                      [Exp0
ls, Ext (L Loc
_ (Ext (FunRefE [Ty0]
_ Var
fp)))] -> [Exp0
ls, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                      [Exp0]
_ -> [Char] -> [Exp0]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Exp0]) -> [Char] -> [Exp0]
forall a b. (a -> b) -> a -> b
$ [Char]
"desugarL0: vsort" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
                  InplaceVSortP{} ->
                    case [Exp0]
args of
                      [Exp0
ls, Ext (FunRefE [Ty0]
_ Var
fp)]             -> [Exp0
ls, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                      [Exp0
ls, Ext (L Loc
_ (Ext (FunRefE [Ty0]
_ Var
fp)))] -> [Exp0
ls, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                      [Exp0]
_ -> [Char] -> [Exp0]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Exp0]) -> [Char] -> [Exp0]
forall a b. (a -> b) -> a -> b
$ [Char]
"desugarL0: vsort" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex
                  Prim Ty0
_ -> [Exp0]
args
          [Exp0]
args'' <- (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
args'
          Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr [Exp0]
args''
        LetE (Var
v,[Ty0]
_tyapps,(ProdTy [Ty0]
tys),(Ext (ParE0 [Exp0]
ls))) Exp0
bod -> do
          [Var]
vs <- (Exp0 -> PassM Var) -> [Exp0] -> 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 (\Exp0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"par_") [Exp0]
ls
          let xs :: [(Var, Ty0, Exp0)]
xs = ([Var] -> [Ty0] -> [Exp0] -> [(Var, Ty0, Exp0)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Var]
vs [Ty0]
tys [Exp0]
ls)
              spawns :: [(Var, Ty0, Exp0)]
spawns = [(Var, Ty0, Exp0)] -> [(Var, Ty0, Exp0)]
forall a. HasCallStack => [a] -> [a]
init [(Var, Ty0, Exp0)]
xs
              (Var
a,Ty0
b,Exp0
c) = [(Var, Ty0, Exp0)] -> (Var, Ty0, Exp0)
forall a. HasCallStack => [a] -> a
last [(Var, Ty0, Exp0)]
xs
              ls' :: [(Var, [Ty0], Ty0, Exp0)]
ls' = ((Var, Ty0, Exp0)
 -> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)])
-> [(Var, [Ty0], Ty0, Exp0)]
-> [(Var, Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                      (\(Var
w,Ty0
ty1,(AppE Var
fn [Ty0]
tyapps1 [Exp0]
args)) [(Var, [Ty0], Ty0, Exp0)]
acc ->
                         (Var
w,[],Ty0
ty1,(Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
fn [Ty0]
tyapps1 [Exp0]
args)) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc)
                      []
                      [(Var, Ty0, Exp0)]
spawns
              ls'' :: [(Var, [Ty0], Ty0, Exp0)]
ls'' = [(Var, [Ty0], Ty0, Exp0)]
ls' [(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [(Var
a,[],Ty0
b,Exp0
c)]
          [(Var, [Ty0], Ty0, Exp0)]
ls''' <- ((Var, [Ty0], Ty0, Exp0) -> PassM (Var, [Ty0], Ty0, Exp0))
-> [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
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 (\(Var
w,[Ty0]
x,Ty0
y,Exp0
z) -> (Var
w,[Ty0]
x,Ty0
y,) (Exp0 -> (Var, [Ty0], Ty0, Exp0))
-> PassM Exp0 -> PassM (Var, [Ty0], Ty0, Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
z) [(Var, [Ty0], Ty0, Exp0)]
ls''
          let binds :: [(Var, [Ty0], Ty0, Exp0)]
binds = [(Var, [Ty0], Ty0, Exp0)]
ls''' [(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [(Var
"_", [], [Ty0] -> Ty0
ProdTy [], Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)]
              bod' :: Exp0
bod' = (((Var, [Ty0], Ty0, Exp0), Int) -> Exp0 -> Exp0)
-> Exp0 -> [((Var, [Ty0], Ty0, Exp0), Int)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\((Var
x,[Ty0]
_,Ty0
_,Exp0
_),Int
i) Exp0
acc ->
                                Exp0 -> Exp0 -> Exp0 -> Exp0
forall e. Substitutable e => e -> e -> e -> e
gSubstE (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x) Exp0
acc)
                           Exp0
bod
                           ([(Var, [Ty0], Ty0, Exp0)]
-> [Int] -> [((Var, [Ty0], Ty0, Exp0), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Var, [Ty0], Ty0, Exp0)]
ls''' [Int
0..])
          Exp0
bod'' <- Exp0 -> PassM Exp0
go Exp0
bod'
          Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$  [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [Ty0], Ty0, Exp0)]
binds Exp0
bod''
        LetE (Var
v,[Ty0]
tyapps,Ty0
ty,Exp0
rhs) Exp0
bod -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE ((Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0)
-> (Exp0 -> (Var, [Ty0], Ty0, Exp0)) -> Exp0 -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var
v,[Ty0]
tyapps,Ty0
ty,) (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
rhs PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> PassM Exp0
go Exp0
bod
        IfE Exp0
a Exp0
b Exp0
c  -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> PassM Exp0 -> PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
a PassM (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> PassM Exp0
go Exp0
b PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp0 -> PassM Exp0
go Exp0
c
        MkProdE [Exp0]
ls -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
ls
        ProjE Int
i Exp0
a  -> (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
a
        CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> do
          Exp0
scrt' <- Exp0 -> PassM Exp0
go Exp0
scrt
          [([Char], [(Var, Ty0)], Exp0)]
brs' <- (([Char], [(Var, Ty0)], Exp0)
 -> PassM ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)]
-> PassM [([Char], [(Var, Ty0)], Exp0)]
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]
dcon,[(Var, Ty0)]
vtys,Exp0
bod) -> do
                          let ([Var]
xs,[Ty0]
_tyapps) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
vtys
                          Exp0
bod' <- Exp0 -> PassM Exp0
go Exp0
bod
                          let dcon_tys :: [Ty0]
dcon_tys = Map Var DDef0 -> [Char] -> [Ty0]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf Exp0)
Map Var DDef0
ddefs [Char]
dcon
                              flattenTupleArgs :: (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0)
                              flattenTupleArgs :: (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0)
flattenTupleArgs (Var
v, Ty0
vty) ([Var]
vs0, Exp0
bod0) =
                                case Ty0
vty of
                                  ProdTy [Ty0]
ls -> do
                                    -- create projection variables: v = (y1, y2, ...)
                                    [Var]
ys <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [Ty0]
ls
                                    -- substitute projections in body with new variable: yi = ProjE i v
                                    let bod1 :: Exp0
bod1 = ((Int, Var) -> Exp0 -> Exp0) -> Exp0 -> [(Int, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, Var
y) Exp0
bod1' -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall e. Substitutable e => e -> e -> e -> e
gSubstE (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
y) Exp0
bod1') Exp0
bod0 ([Int] -> [Var] -> [(Int, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Var]
ys)
                                    -- substitute whole variable v with product: v = MkProdE (y1, y2, ...)
                                    let bod2 :: Exp0
bod2 = Exp0 -> Exp0 -> Exp0 -> Exp0
forall e. Substitutable e => e -> e -> e -> e
gSubstE (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v) ([Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ((Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys)) Exp0
bod1
                                    -- flatten each of yis
                                    ([Var]
ys', Exp0
bod3) <- ((Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0))
-> ([Var], Exp0) -> [(Var, Ty0)] -> PassM ([Var], Exp0)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0)
flattenTupleArgs ([Var]
vs0, Exp0
bod2) ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ys [Ty0]
ls)
                                    ([Var], Exp0) -> PassM ([Var], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Var]
ys', Exp0
bod3)
                                  Ty0
_ -> ([Var], Exp0) -> PassM ([Var], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
vVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
vs0, Exp0
bod0)

                          ([Var]
xs',Exp0
bod'') <- ((Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0))
-> ([Var], Exp0) -> [(Var, Ty0)] -> PassM ([Var], Exp0)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0)
flattenTupleArgs ([], Exp0
bod') ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
xs [Ty0]
dcon_tys)
                          let vtys' :: [(Var, Ty0)]
vtys' = [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
xs' (Ty0 -> [Ty0]
forall a. a -> [a]
repeat ([Ty0] -> Ty0
ProdTy []))
                          ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
dcon, [(Var, Ty0)]
vtys', Exp0
bod''))
                       [([Char], [(Var, Ty0)], Exp0)]
brs
          Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs'
        DataConE Ty0
a [Char]
dcon [Exp0]
ls -> do
          [Exp0]
ls' <- (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
ls
          let tys :: [Ty0]
tys = Map Var DDef0 -> [Char] -> [Ty0]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf Exp0)
Map Var DDef0
ddefs [Char]
dcon
              flattenTupleArgs :: Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)] ,[Exp0])
              flattenTupleArgs :: forall loc.
Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
flattenTupleArgs Exp0
arg Ty0
ty = case Ty0
ty of
                ProdTy [Ty0]
tys' ->
                  case Exp0
arg of
                    MkProdE [Exp0]
args -> do
                      ([[(Var, [loc], Ty0, Exp0)]]
bnds', [[Exp0]]
args') <- [([(Var, [loc], Ty0, Exp0)], [Exp0])]
-> ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [loc], Ty0, Exp0)], [Exp0])]
 -> ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]]))
-> PassM [([(Var, [loc], Ty0, Exp0)], [Exp0])]
-> PassM ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0]))
-> [Exp0] -> [Ty0] -> PassM [([(Var, [loc], Ty0, Exp0)], [Exp0])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
forall loc.
Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
flattenTupleArgs [Exp0]
args [Ty0]
tys'
                      ([(Var, [loc], Ty0, Exp0)], [Exp0])
-> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [loc], Ty0, Exp0)]] -> [(Var, [loc], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [loc], Ty0, Exp0)]]
bnds',[[Exp0]] -> [Exp0]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Exp0]]
args')
                    Exp0
_ -> do
                        -- generating alias so that repeated expression is
                        -- eliminated and we are taking projection of trivial varEs
                        Var
argalias <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"alias"
                        [Var]
ys <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"proj") [Ty0]
tys'
                        let vs :: [Exp0]
vs = (Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys
                        ([[(Var, [loc], Ty0, Exp0)]]
bnds', [[Exp0]]
args') <-
                          [([(Var, [loc], Ty0, Exp0)], [Exp0])]
-> ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [loc], Ty0, Exp0)], [Exp0])]
 -> ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]]))
-> PassM [([(Var, [loc], Ty0, Exp0)], [Exp0])]
-> PassM ([[(Var, [loc], Ty0, Exp0)]], [[Exp0]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0]))
-> [Exp0] -> [Ty0] -> PassM [([(Var, [loc], Ty0, Exp0)], [Exp0])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
forall loc.
Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
flattenTupleArgs [Exp0]
vs [Ty0]
tys'
                        let bnds'' :: [(Var, [loc], Ty0, Exp0)]
bnds'' =
                              (Var
argalias, [], Ty0
ty, Exp0
arg) (Var, [loc], Ty0, Exp0)
-> [(Var, [loc], Ty0, Exp0)] -> [(Var, [loc], Ty0, Exp0)]
forall a. a -> [a] -> [a]
:
                              [ (Var
y, [], Ty0
ty', Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
argalias))
                              | (Var
y, Ty0
ty', Int
i) <- [Var] -> [Ty0] -> [Int] -> [(Var, Ty0, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Var]
ys [Ty0]
tys' [Int
0 ..]
                              ]
                        ([(Var, [loc], Ty0, Exp0)], [Exp0])
-> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [loc], Ty0, Exp0)]
bnds'' [(Var, [loc], Ty0, Exp0)]
-> [(Var, [loc], Ty0, Exp0)] -> [(Var, [loc], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [[(Var, [loc], Ty0, Exp0)]] -> [(Var, [loc], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [loc], Ty0, Exp0)]]
bnds', [[Exp0]] -> [Exp0]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Exp0]]
args')
                Ty0
_ -> do
                  ([(Var, [loc], Ty0, Exp0)], [Exp0])
-> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Exp0
arg])
          ([[(Var, [Ty0], Ty0, Exp0)]]
binds, [[Exp0]]
args) <- [([(Var, [Ty0], Ty0, Exp0)], [Exp0])]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [[Exp0]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], [Exp0])]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [[Exp0]]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], [Exp0])]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [[Exp0]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> Ty0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], [Exp0]))
-> [Exp0] -> [Ty0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], [Exp0])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Exp0 -> Ty0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], [Exp0])
forall loc.
Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0])
flattenTupleArgs [Exp0]
ls' [Ty0]
tys
          Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
binds) (Exp0 -> Exp0) -> Exp0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
a [Char]
dcon ([[Exp0]] -> [Exp0]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Exp0]]
args)
        TimeIt Exp0
e Ty0
ty IsBoxed
b    -> (\Exp0
a -> Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
a Ty0
ty IsBoxed
b) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
e
        WithArenaE Var
v Exp0
e -> (Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go Exp0
e
        SpawnE Var
fn [Ty0]
tyapps [Exp0]
args -> (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
fn [Ty0]
tyapps) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
args
        Exp0
SyncE   -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
        MapE{}  -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        FoldE{} -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        Ext E0Ext Ty0 Ty0
ext ->
          case E0Ext Ty0 Ty0
ext of
            LambdaE{}  -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            PolyAppE{} -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            FunRefE{}  -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
            BenchE Var
fn [Ty0]
_tyapps [Exp0]
args IsBoxed
b -> (\[Exp0]
a -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> IsBoxed -> E0Ext Ty0 Ty0
forall loc dec.
Var -> [loc] -> [PreExp E0Ext loc dec] -> IsBoxed -> E0Ext loc dec
BenchE Var
fn [] [Exp0]
a IsBoxed
b) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
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 Exp0 -> PassM Exp0
go [Exp0]
args
            ParE0 [Exp0]
ls -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 ([Char]
"unbound ParE0" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Exp0] -> [Char]
forall a. Out a => a -> [Char]
sdoc [Exp0]
ls)
            PrintPacked Ty0
ty Exp0
arg
              | (PackedTy [Char]
tycon [Ty0]
_) <- Ty0
ty -> do
                  let f :: Var
f = [Char] -> Var
mkPrinterName [Char]
tycon
                  Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0
arg]
              | IsBoxed
otherwise -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 ([Char] -> PassM Exp0) -> [Char] -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"printPacked without a packed type. Got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty
            CopyPacked Ty0
ty Exp0
arg
              | (PackedTy [Char]
tycon [Ty0]
_) <- Ty0
ty -> do
                  let f :: Var
f = [Char] -> Var
mkCopyFunName [Char]
tycon
                  Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0
arg]
              | IsBoxed
otherwise -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 ([Char] -> PassM Exp0) -> [Char] -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"printPacked without a packed type. Got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty
            TravPacked Ty0
ty Exp0
arg
              | (PackedTy [Char]
tycon [Ty0]
_) <- Ty0
ty -> do
                  let f :: Var
f = [Char] -> Var
mkTravFunName [Char]
tycon
                  Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp0
arg]
              | IsBoxed
otherwise -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 ([Char] -> PassM Exp0) -> [Char] -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [Char]
"printPacked without a packed type. Got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ty0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Ty0
ty
            L Loc
p Exp0
e   -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0
go Exp0
e)
            LinearExt{} -> [Char] -> PassM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)

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

-- | Add copy & traversal functions for each data type in a prog
addRepairFns :: Prog0 -> PassM Prog0
addRepairFns :: Prog0 -> PassM Prog0
addRepairFns (Prog DDefs (TyOf Exp0)
dfs FunDefs Exp0
fds Maybe (Exp0, TyOf Exp0)
me) = do
  [FunDef0]
newFns <- [[FunDef0]] -> [FunDef0]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FunDef0]] -> [FunDef0]) -> PassM [[FunDef0]] -> PassM [FunDef0]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (DDef0 -> PassM [FunDef0]) -> [DDef0] -> PassM [[FunDef0]]
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 (\DDef0
d -> do
                    FunDef0
copy_fn  <- DDef0 -> PassM FunDef0
genCopyFn DDef0
d
                    FunDef0
copy2_fn <- DDef0 -> PassM FunDef0
genCopySansPtrsFn DDef0
d
                    FunDef0
trav_fn  <- DDef0 -> PassM FunDef0
genTravFn DDef0
d
                    FunDef0
print_fn <- DDef0 -> PassM FunDef0
genPrintFn DDef0
d
                    [FunDef0] -> PassM [FunDef0]
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return [FunDef0
copy_fn, FunDef0
copy2_fn, FunDef0
trav_fn, FunDef0
print_fn])
              ((DDef0 -> IsBoxed) -> [DDef0] -> [DDef0]
forall a. (a -> IsBoxed) -> [a] -> [a]
filter (IsBoxed -> IsBoxed
not (IsBoxed -> IsBoxed) -> (DDef0 -> IsBoxed) -> DDef0 -> IsBoxed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DDef0 -> IsBoxed
forall {a}. DDef a -> IsBoxed
isVoidDDef) (Map Var DDef0 -> [DDef0]
forall k a. Map k a -> [a]
M.elems DDefs (TyOf Exp0)
Map Var DDef0
dfs))
  let fds' :: FunDefs Exp0
fds' = FunDefs Exp0
fds FunDefs Exp0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` ([(Var, FunDef0)] -> FunDefs Exp0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, FunDef0)] -> FunDefs Exp0)
-> [(Var, FunDef0)] -> FunDefs Exp0
forall a b. (a -> b) -> a -> b
$ (FunDef0 -> (Var, FunDef0)) -> [FunDef0] -> [(Var, FunDef0)]
forall a b. (a -> b) -> [a] -> [b]
map (\FunDef0
f -> (FunDef0 -> Var
forall ex. FunDef ex -> Var
funName FunDef0
f, FunDef0
f)) [FunDef0]
newFns)
  Prog0 -> PassM Prog0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp0)
-> FunDefs Exp0 -> Maybe (Exp0, TyOf Exp0) -> Prog0
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp0)
dfs FunDefs Exp0
fds' Maybe (Exp0, TyOf Exp0)
me


-- | Generate a copy function for a particular data definition.
-- Note: there will be redundant let bindings in the function body which may need to be inlined.
genCopyFn :: DDef0 -> PassM FunDef0
genCopyFn :: DDef0 -> PassM FunDef0
genCopyFn DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName, [([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = do
  Var
arg <- 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
$ Var
"arg"
  [([Char], [(Var, Ty0)], Exp0)]
casebod <- [([Char], [(IsBoxed, Ty0)])]
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(IsBoxed, Ty0)])]
dataCons ((([Char], [(IsBoxed, Ty0)]) -> PassM ([Char], [(Var, Ty0)], Exp0))
 -> PassM [([Char], [(Var, Ty0)], Exp0)])
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ \([Char]
dcon, [(IsBoxed, Ty0)]
dtys) ->
             do let tys :: [Ty0]
tys = ((IsBoxed, Ty0) -> Ty0) -> [(IsBoxed, Ty0)] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (IsBoxed, Ty0) -> Ty0
forall a b. (a, b) -> b
snd [(IsBoxed, Ty0)]
dtys
                [Var]
xs <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"x") [Ty0]
tys
                [Var]
ys <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [Ty0]
tys
                -- let packed_vars = map fst $ filter (\(x,ty) -> isPackedTy ty) (zip ys tys)
                let bod :: Exp0
bod = ((Ty0, Var, Var) -> Exp0 -> Exp0)
-> Exp0 -> [(Ty0, Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Ty0
ty,Var
x,Var
y) Exp0
acc ->
                                     case Ty0
ty of
                                       PackedTy [Char]
tycon [Ty0]
_ -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], Ty0
ty, Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE ([Char] -> Var
mkCopyFunName [Char]
tycon) [] [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) Exp0
acc
                                       Ty0
_ -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], Ty0
ty, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x) Exp0
acc)
                            (Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy []) [Char]
dcon ([Exp0] -> Exp0) -> [Exp0] -> Exp0
forall a b. (a -> b) -> a -> b
$ (Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys) ([Ty0] -> [Var] -> [Var] -> [(Ty0, Var, Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Ty0]
tys [Var]
xs [Var]
ys)
                ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dcon, (Var -> (Var, Ty0)) -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
x -> (Var
x,([Ty0] -> Ty0
ProdTy []))) [Var]
xs, Exp0
bod)
  FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef { funName :: Var
funName = [Char] -> Var
mkCopyFunName (Var -> [Char]
fromVar Var
tyName)
                  , funArgs :: [Var]
funArgs = [Var
arg]
                  , funTy :: ArrowTy (TyOf Exp0)
funTy   = ([TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [[Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) []] ([Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) [])))
                  , funBody :: Exp0
funBody = Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
arg) [([Char], [(Var, Ty0)], Exp0)]
casebod
                  , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
Rec
                                      , funInline :: FunInline
funInline = FunInline
NoInline
                                      , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                      }
                  }

genCopySansPtrsFn :: DDef0 -> PassM FunDef0
genCopySansPtrsFn :: DDef0 -> PassM FunDef0
genCopySansPtrsFn DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName,[([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = do
  Var
arg <- 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
$ Var
"arg"
  [([Char], [(Var, Ty0)], Exp0)]
casebod <- [([Char], [(IsBoxed, Ty0)])]
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(IsBoxed, Ty0)])]
dataCons ((([Char], [(IsBoxed, Ty0)]) -> PassM ([Char], [(Var, Ty0)], Exp0))
 -> PassM [([Char], [(Var, Ty0)], Exp0)])
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ \([Char]
dcon, [(IsBoxed, Ty0)]
dtys) ->
             do let tys :: [Ty0]
tys = ((IsBoxed, Ty0) -> Ty0) -> [(IsBoxed, Ty0)] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (IsBoxed, Ty0) -> Ty0
forall a b. (a, b) -> b
snd [(IsBoxed, Ty0)]
dtys
                [Var]
xs <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"x") [Ty0]
tys
                [Var]
ys <- (Ty0 -> PassM Var) -> [Ty0] -> 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 (\Ty0
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [Ty0]
tys
                -- let packed_vars = map fst $ filter (\(x,ty) -> isPackedTy ty) (zip ys tys)
                let bod :: Exp0
bod = ((Ty0, Var, Var) -> Exp0 -> Exp0)
-> Exp0 -> [(Ty0, Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Ty0
ty,Var
x,Var
y) Exp0
acc ->
                                     case Ty0
ty of
                                       PackedTy [Char]
tycon [Ty0]
_ -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], Ty0
ty, Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE ([Char] -> Var
mkCopySansPtrsFunName [Char]
tycon) [] [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) Exp0
acc
                                       Ty0
_ -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], Ty0
ty, Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x) Exp0
acc)
                            (Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ([Ty0] -> Ty0
ProdTy []) [Char]
dcon ([Exp0] -> Exp0) -> [Exp0] -> Exp0
forall a b. (a -> b) -> a -> b
$ (Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys) ([Ty0] -> [Var] -> [Var] -> [(Ty0, Var, Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Ty0]
tys [Var]
xs [Var]
ys)
                ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dcon, (Var -> (Var, Ty0)) -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
x -> (Var
x,([Ty0] -> Ty0
ProdTy []))) [Var]
xs, Exp0
bod)
  FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef { funName :: Var
funName = [Char] -> Var
mkCopySansPtrsFunName (Var -> [Char]
fromVar Var
tyName)
                  , funArgs :: [Var]
funArgs = [Var
arg]
                  , funTy :: ArrowTy (TyOf Exp0)
funTy   = ([TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [[Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) []] ([Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) [])))
                  , funBody :: Exp0
funBody = Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
arg) [([Char], [(Var, Ty0)], Exp0)]
casebod
                  , funMeta :: FunMeta
funMeta = FunMeta  { funRec :: FunRec
funRec = FunRec
Rec
                                       , funInline :: FunInline
funInline = FunInline
NoInline
                                       , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                       }
                  }




-- | Traverses a packed data type.
genTravFn :: DDef0 -> PassM FunDef0
genTravFn :: DDef0 -> PassM FunDef0
genTravFn DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName, [([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = do
  Var
arg <- 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
$ Var
"arg"
  [([Char], [(Var, Ty0)], Exp0)]
casebod <- [([Char], [(IsBoxed, Ty0)])]
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(IsBoxed, Ty0)])]
dataCons ((([Char], [(IsBoxed, Ty0)]) -> PassM ([Char], [(Var, Ty0)], Exp0))
 -> PassM [([Char], [(Var, Ty0)], Exp0)])
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ \([Char]
dcon, [(IsBoxed, Ty0)]
tys) ->
             do [Var]
xs <- ((IsBoxed, Ty0) -> PassM Var) -> [(IsBoxed, Ty0)] -> 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 (\(IsBoxed, Ty0)
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"x") [(IsBoxed, Ty0)]
tys
                [Var]
ys <- ((IsBoxed, Ty0) -> PassM Var) -> [(IsBoxed, Ty0)] -> 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 (\(IsBoxed, Ty0)
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [(IsBoxed, Ty0)]
tys
                let bod :: Exp0
bod = ((Ty0, Var, Var) -> Exp0 -> Exp0)
-> Exp0 -> [(Ty0, Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Ty0
ty,Var
x,Var
y) Exp0
acc ->
                                     case Ty0
ty of
                                       PackedTy [Char]
tycon [Ty0]
_ -> (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], [Ty0] -> Ty0
ProdTy [], Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE ([Char] -> Var
mkTravFunName [Char]
tycon) [] [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) Exp0
acc
                                       Ty0
_ -> Exp0
acc)
                          ([Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [])
                          ([Ty0] -> [Var] -> [Var] -> [(Ty0, Var, Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (((IsBoxed, Ty0) -> Ty0) -> [(IsBoxed, Ty0)] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (IsBoxed, Ty0) -> Ty0
forall a b. (a, b) -> b
snd [(IsBoxed, Ty0)]
tys) [Var]
xs [Var]
ys)
                ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dcon, (Var -> (Var, Ty0)) -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
x -> (Var
x,[Ty0] -> Ty0
ProdTy [])) [Var]
xs, Exp0
bod)
  FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef { funName :: Var
funName = [Char] -> Var
mkTravFunName (Var -> [Char]
fromVar Var
tyName)
                  , funArgs :: [Var]
funArgs = [Var
arg]
                  , funTy :: ArrowTy (TyOf Exp0)
funTy   = ([TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [[Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) []] ([Ty0] -> Ty0
ProdTy [])))
                  , funBody :: Exp0
funBody = Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
arg) [([Char], [(Var, Ty0)], Exp0)]
casebod
                  , funMeta :: FunMeta
funMeta = FunMeta  { funRec :: FunRec
funRec = FunRec
Rec
                                       , funInline :: FunInline
funInline = FunInline
NoInline
                                       , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                       }
                  }


-- | Print a packed datatype.
genPrintFn :: DDef0 -> PassM FunDef0
genPrintFn :: DDef0 -> PassM FunDef0
genPrintFn DDef{Var
tyName :: forall a. DDef a -> Var
tyName :: Var
tyName, [([Char], [(IsBoxed, Ty0)])]
dataCons :: forall a. DDef a -> [([Char], [(IsBoxed, a)])]
dataCons :: [([Char], [(IsBoxed, Ty0)])]
dataCons} = do
  Var
arg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"arg"
  [([Char], [(Var, Ty0)], Exp0)]
casebod <- [([Char], [(IsBoxed, Ty0)])]
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(IsBoxed, Ty0)])]
dataCons ((([Char], [(IsBoxed, Ty0)]) -> PassM ([Char], [(Var, Ty0)], Exp0))
 -> PassM [([Char], [(Var, Ty0)], Exp0)])
-> (([Char], [(IsBoxed, Ty0)])
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ \([Char]
dcon, [(IsBoxed, Ty0)]
tys) ->
             do [Var]
xs <- ((IsBoxed, Ty0) -> PassM Var) -> [(IsBoxed, Ty0)] -> 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 (\(IsBoxed, Ty0)
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"x") [(IsBoxed, Ty0)]
tys
                [Var]
ys <- ((IsBoxed, Ty0) -> PassM Var) -> [(IsBoxed, Ty0)] -> 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 (\(IsBoxed, Ty0)
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [(IsBoxed, Ty0)]
tys
                let bnds :: [(Var, [Ty0], Ty0, Exp0)]
bnds = ((Ty0, Var, Var)
 -> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)])
-> [(Var, [Ty0], Ty0, Exp0)]
-> [(Ty0, Var, Var)]
-> [(Var, [Ty0], Ty0, Exp0)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Ty0
ty,Var
x,Var
y) [(Var, [Ty0], Ty0, Exp0)]
acc ->
                                     case Ty0
ty of
                                       Ty0
IntTy   -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintInt [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       Ty0
FloatTy -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintFloat [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       Ty0
SymTy0  -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       Ty0
BoolTy  -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintBool [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       PackedTy [Char]
tycon [Ty0]
_ -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE ([Char] -> Var
mkPrinterName [Char]
tycon) [] [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       SymDictTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"SymDict")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       VectorTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"Vector")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       PDictTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"PDict")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       ListTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"List")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       ArenaTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"Arena")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       SymSetTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"SymSet")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       SymHashTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"SymHash")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       IntHashTy{} -> (Var
y, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
"IntHash")]) (Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, [Ty0], Ty0, Exp0)]
acc
                                       Ty0
_ -> [(Var, [Ty0], Ty0, Exp0)]
acc)
                          []
                          ([Ty0] -> [Var] -> [Var] -> [(Ty0, Var, Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (((IsBoxed, Ty0) -> Ty0) -> [(IsBoxed, Ty0)] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (IsBoxed, Ty0) -> Ty0
forall a b. (a, b) -> b
snd [(IsBoxed, Ty0)]
tys) [Var]
xs [Var]
ys)
                Var
w1 <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"wildcard"
                Var
w2 <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"wildcard"
                let add_spaces :: [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)] -> PassM [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)]
                    add_spaces :: [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
add_spaces [] = [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                    add_spaces [(Var, [Ty0], Ty0, Exp0)
z] = [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Var, [Ty0], Ty0, Exp0)
z]
                    add_spaces ((Var, [Ty0], Ty0, Exp0)
z:[(Var, [Ty0], Ty0, Exp0)]
zs) = do
                      [(Var, [Ty0], Ty0, Exp0)]
zs' <- [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
add_spaces [(Var, [Ty0], Ty0, Exp0)]
zs
                      Var
wi <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"wildcard"
                      [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)])
-> [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0)
z(Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
:(Var
wi, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [(Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
" "))] )(Var, [Ty0], Ty0, Exp0)
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. a -> [a] -> [a]
:[(Var, [Ty0], Ty0, Exp0)]
zs'

                [(Var, [Ty0], Ty0, Exp0)]
bnds'' <- [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
add_spaces ([(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)])
-> [(Var, [Ty0], Ty0, Exp0)] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall a b. (a -> b) -> a -> b
$ [(Var
w1, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [(Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar ([Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dcon)))])] [(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [(Var, [Ty0], Ty0, Exp0)]
bnds
                let bnds' :: [(Var, [Ty0], Ty0, Exp0)]
bnds' = [(Var, [Ty0], Ty0, Exp0)]
bnds'' [(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++ [(Var
w2, [], [Ty0] -> Ty0
ProdTy [], Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
PrintSym [(Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE ([Char] -> Var
toVar [Char]
")"))])]
                    bod :: Exp0
bod = [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [Ty0], Ty0, Exp0)]
bnds' ([Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [])
                ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dcon, (Var -> (Var, Ty0)) -> [Var] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
x -> (Var
x,[Ty0] -> Ty0
ProdTy [])) [Var]
xs, Exp0
bod)
  FunDef0 -> PassM FunDef0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef0 -> PassM FunDef0) -> FunDef0 -> PassM FunDef0
forall a b. (a -> b) -> a -> b
$ FunDef { funName :: Var
funName = [Char] -> Var
mkPrinterName (Var -> [Char]
fromVar Var
tyName)
                  , funArgs :: [Var]
funArgs = [Var
arg]
                  , funTy :: ArrowTy (TyOf Exp0)
funTy   = ([TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [[Char] -> [Ty0] -> Ty0
PackedTy (Var -> [Char]
fromVar Var
tyName) []] ([Ty0] -> Ty0
ProdTy [])))
                  , funBody :: Exp0
funBody = Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
arg) [([Char], [(Var, Ty0)], Exp0)]
casebod
                  , funMeta :: FunMeta
funMeta = FunMeta  { funRec :: FunRec
funRec = FunRec
Rec
                                       , funInline :: FunInline
funInline = FunInline
NoInline
                                       , funCanTriggerGC :: IsBoxed
funCanTriggerGC = IsBoxed
False
                                       }
                  }


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

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

type FloatState = FunDefs0
type FloatM a = StateT FloatState PassM a

floatOutCase :: Prog0 -> PassM Prog0
floatOutCase :: Prog0 -> PassM Prog0
floatOutCase (Prog DDefs (TyOf Exp0)
ddefs FunDefs Exp0
fundefs Maybe (Exp0, TyOf Exp0)
mainExp) = do
    let float_m :: StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
float_m = do
          (FunDef0 -> StateT (FunDefs Exp0) PassM ())
-> [FunDef0] -> StateT (FunDefs Exp0) PassM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            (\fn :: FunDef0
fn@FunDef{Var
funName :: forall ex. FunDef ex -> Var
funName :: Var
funName,[Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs,ArrowTy (TyOf Exp0)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp0)
funTy,Exp0
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp0
funBody} -> do
                  FunDefs Exp0
fstate <- StateT (FunDefs Exp0) PassM (FunDefs Exp0)
forall s (m :: * -> *). MonadState s m => m s
get
                  let venv :: TyEnv Ty0
venv = [(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Var]
funArgs (ArrowTy Ty0 -> [Ty0]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp0)
ArrowTy Ty0
funTy))
                  let env2 :: Env2 Ty0
env2 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 TyEnv Ty0
venv (FunDefs Exp0 -> TyEnv (ArrowTy (TyOf Exp0))
forall a. FunDefs a -> TyEnv (ArrowTy (TyOf a))
initFunEnv FunDefs Exp0
fstate)
                  Exp0
funBody' <- IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
False Env2 Ty0
env2 Exp0
funBody
                  let fn' :: FunDef0
fn' = FunDef0
fn { funBody :: Exp0
funBody = Exp0
funBody' }
                  (FunDefs Exp0 -> ((), FunDefs Exp0))
-> StateT (FunDefs Exp0) PassM ()
forall a.
(FunDefs Exp0 -> (a, FunDefs Exp0))
-> StateT (FunDefs Exp0) PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\FunDefs Exp0
s -> ((), Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
funName FunDef0
fn' FunDefs Exp0
s)))
            (FunDefs Exp0 -> [FunDef0]
forall k a. Map k a -> [a]
M.elems FunDefs Exp0
fundefs)
          Maybe (Exp0, Ty0)
float_main <- do
             FunDefs Exp0
fstate <- StateT (FunDefs Exp0) PassM (FunDefs Exp0)
forall s (m :: * -> *). MonadState s m => m s
get
             let env2 :: Env2 Ty0
env2 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 TyEnv Ty0
forall k a. Map k a
M.empty (FunDefs Exp0 -> TyEnv (ArrowTy (TyOf Exp0))
forall a. FunDefs a -> TyEnv (ArrowTy (TyOf a))
initFunEnv FunDefs Exp0
fstate)
             case Maybe (Exp0, TyOf Exp0)
mainExp of
               Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp0, Ty0)
-> StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
               Just (Exp0
e,TyOf Exp0
ty) -> (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just ((Exp0, Ty0) -> Maybe (Exp0, Ty0))
-> (Exp0 -> (Exp0, Ty0)) -> Exp0 -> Maybe (Exp0, Ty0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,TyOf Exp0
Ty0
ty) (Exp0 -> Maybe (Exp0, Ty0))
-> FloatM Exp0 -> StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2 Exp0
e
          Maybe (Exp0, Ty0)
-> StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp0, Ty0)
float_main

    (Maybe (Exp0, Ty0)
mainExp',FunDefs Exp0
state') <- StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
-> FunDefs Exp0 -> PassM (Maybe (Exp0, Ty0), FunDefs Exp0)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (FunDefs Exp0) PassM (Maybe (Exp0, Ty0))
float_m FunDefs Exp0
fundefs
    Prog0 -> PassM Prog0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ (DDefs (TyOf Exp0)
-> FunDefs Exp0 -> Maybe (Exp0, TyOf Exp0) -> Prog0
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp0)
ddefs FunDefs Exp0
state' Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mainExp')
  where
    err1 :: [Char] -> a
err1 [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"floatOutCase: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg

    float_fn :: Env2 Ty0 -> Exp0 -> FloatM Exp0
    float_fn :: Env2 Ty0 -> Exp0 -> FloatM Exp0
float_fn Env2 Ty0
env2 Exp0
ex = do
      FunDefs Exp0
fundefs' <- StateT (FunDefs Exp0) PassM (FunDefs Exp0)
forall s (m :: * -> *). MonadState s m => m s
get
      let fenv' :: TyEnv (ArrowTy (TyOf Exp0))
fenv' = (FunDef0 -> ArrowTy (TyOf Exp0))
-> FunDefs Exp0 -> TyEnv (ArrowTy (TyOf Exp0))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FunDef0 -> ArrowTy (TyOf Exp0)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDefs Exp0
fundefs'
          env2' :: Env2 Ty0
env2' = Env2 Ty0
env2 {fEnv :: TyEnv (ArrowTy Ty0)
fEnv = TyEnv (ArrowTy (TyOf Exp0))
TyEnv (ArrowTy Ty0)
fenv'}
          free :: [Var]
free = Set Var -> [Var]
forall a. Set a -> [a]
S.toList (Set Var -> [Var]) -> Set Var -> [Var]
forall a b. (a -> b) -> a -> b
$ Exp0 -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars Exp0
ex Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` (FunDefs Exp0 -> Set Var
forall k a. Map k a -> Set k
M.keysSet FunDefs Exp0
fundefs')
          in_tys :: [Ty0]
in_tys = (Var -> Ty0) -> [Var] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
map (\Var
x -> Var -> Env2 Ty0 -> Ty0
forall a. Out a => Var -> Env2 a -> a
lookupVEnv Var
x Env2 Ty0
env2') [Var]
free
          ret_ty :: Ty0
ret_ty = Map Var DDef0 -> Env2 Ty0 -> Exp0 -> Ty0
recoverType DDefs (TyOf Exp0)
Map Var DDef0
ddefs Env2 Ty0
env2' Exp0
ex
          fn_ty :: TyScheme
fn_ty = [TyVar] -> Ty0 -> TyScheme
ForAll [] ([Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
in_tys Ty0
ret_ty)
      Var
fn_name <- PassM Var -> StateT (FunDefs Exp0) PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT (FunDefs Exp0) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT (FunDefs Exp0) PassM Var)
-> PassM Var -> StateT (FunDefs Exp0) PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"caseFn"
      [Var]
args <- (Var -> StateT (FunDefs Exp0) PassM Var)
-> [Var] -> StateT (FunDefs Exp0) 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 (\Var
x -> PassM Var -> StateT (FunDefs Exp0) PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT (FunDefs Exp0) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT (FunDefs Exp0) PassM Var)
-> PassM Var -> StateT (FunDefs Exp0) PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
x) [Var]
free
      let ex' :: Exp0
ex' = ((Var, Var) -> Exp0 -> Exp0) -> Exp0 -> [(Var, Var)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Var
from,Var
to) Exp0
acc -> Var -> Exp0 -> Exp0 -> Exp0
forall e. Substitutable e => Var -> e -> e -> e
gSubst Var
from (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
to) Exp0
acc) Exp0
ex ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
free [Var]
args)
      let fn :: FunDef0
fn = Var -> [Var] -> ArrowTy (TyOf Exp0) -> Exp0 -> FunMeta -> FunDef0
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
fn_name [Var]
args ArrowTy (TyOf Exp0)
TyScheme
fn_ty Exp0
ex' (FunRec -> FunInline -> IsBoxed -> FunMeta
FunMeta FunRec
NotRec FunInline
NoInline IsBoxed
False)
      (FunDefs Exp0 -> (Exp0, FunDefs Exp0)) -> FloatM Exp0
forall a.
(FunDefs Exp0 -> (a, FunDefs Exp0))
-> StateT (FunDefs Exp0) PassM a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\FunDefs Exp0
s -> ((Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fn_name [] ((Var -> Exp0) -> [Var] -> [Exp0]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
free)), Var -> FunDef0 -> FunDefs Exp0 -> FunDefs Exp0
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
fn_name FunDef0
fn FunDefs Exp0
s))

    go :: Bool -> Env2 Ty0 -> Exp0 -> FloatM Exp0
    go :: IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
float Env2 Ty0
env2 Exp0
ex =
      case Exp0
ex of
        VarE{}    -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        LitE{}    -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        CharE{}   -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        FloatE{}  -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        LitSymE{} -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        AppE Var
f [Ty0]
tyapps [Exp0]
args-> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Ty0]
tyapps ([Exp0] -> Exp0)
-> StateT (FunDefs Exp0) PassM [Exp0] -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> FloatM Exp0)
-> [Exp0] -> StateT (FunDefs Exp0) PassM [Exp0]
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 Exp0 -> FloatM Exp0
recur [Exp0]
args
        PrimAppE Prim Ty0
pr [Exp0]
args  -> do
          [Exp0]
args' <- (Exp0 -> FloatM Exp0)
-> [Exp0] -> StateT (FunDefs Exp0) PassM [Exp0]
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 Exp0 -> FloatM Exp0
recur [Exp0]
args
          Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> FloatM Exp0) -> Exp0 -> FloatM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
pr [Exp0]
args'
        LetE (Var
v,[Ty0]
tyapps,Ty0
ty,Exp0
rhs) Exp0
bod ->  do
          Exp0
rhs' <- IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2 Exp0
rhs
          let env2' :: Env2 Ty0
env2'= Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
ty Env2 Ty0
env2
          Exp0
bod' <- IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2' Exp0
bod
          Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> FloatM Exp0) -> Exp0 -> FloatM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Ty0]
tyapps,Ty0
ty,Exp0
rhs') Exp0
bod'
        IfE Exp0
a Exp0
b Exp0
c  -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> FloatM Exp0
-> StateT (FunDefs Exp0) PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2 Exp0
a StateT (FunDefs Exp0) PassM (Exp0 -> Exp0 -> Exp0)
-> FloatM Exp0 -> StateT (FunDefs Exp0) PassM (Exp0 -> Exp0)
forall a b.
StateT (FunDefs Exp0) PassM (a -> b)
-> StateT (FunDefs Exp0) PassM a -> StateT (FunDefs Exp0) PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2 Exp0
b StateT (FunDefs Exp0) PassM (Exp0 -> Exp0)
-> FloatM Exp0 -> FloatM Exp0
forall a b.
StateT (FunDefs Exp0) PassM (a -> b)
-> StateT (FunDefs Exp0) PassM a -> StateT (FunDefs Exp0) PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2 Exp0
c
        MkProdE [Exp0]
ls -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0)
-> StateT (FunDefs Exp0) PassM [Exp0] -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> FloatM Exp0)
-> [Exp0] -> StateT (FunDefs Exp0) PassM [Exp0]
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 Exp0 -> FloatM Exp0
recur [Exp0]
ls
        ProjE Int
i Exp0
a  -> (Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i) (Exp0 -> Exp0) -> FloatM Exp0 -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> FloatM Exp0
recur Exp0
a
        CaseE Exp0
scrt [([Char], [(Var, Ty0)], Exp0)]
brs -> do
          Exp0
scrt' <- IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
float Env2 Ty0
env2 Exp0
scrt
          [([Char], [(Var, Ty0)], Exp0)]
brs' <- (([Char], [(Var, Ty0)], Exp0)
 -> StateT (FunDefs Exp0) PassM ([Char], [(Var, Ty0)], Exp0))
-> [([Char], [(Var, Ty0)], Exp0)]
-> StateT (FunDefs Exp0) PassM [([Char], [(Var, Ty0)], Exp0)]
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]
dcon,[(Var, Ty0)]
vtys,Exp0
rhs) -> do
                          let vars :: [Var]
vars = ((Var, Ty0) -> Var) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty0) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty0)]
vtys
                          let tys :: [Ty0]
tys = Map Var DDef0 -> [Char] -> [Ty0]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs (TyOf Exp0)
Map Var DDef0
ddefs [Char]
dcon
                          let env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars [Ty0]
tys)) Env2 Ty0
env2
                          Exp0
rhs' <- IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
True Env2 Ty0
env2' Exp0
rhs
                          ([Char], [(Var, Ty0)], Exp0)
-> StateT (FunDefs Exp0) PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
dcon,[(Var, Ty0)]
vtys,Exp0
rhs'))
                       [([Char], [(Var, Ty0)], Exp0)]
brs
          if IsBoxed
float
          then Env2 Ty0 -> Exp0 -> FloatM Exp0
float_fn Env2 Ty0
env2 (Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs')
          else Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> FloatM Exp0) -> Exp0 -> FloatM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
scrt' [([Char], [(Var, Ty0)], Exp0)]
brs'
        DataConE Ty0
a [Char]
dcon [Exp0]
ls -> Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
a [Char]
dcon ([Exp0] -> Exp0)
-> StateT (FunDefs Exp0) PassM [Exp0] -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> FloatM Exp0)
-> [Exp0] -> StateT (FunDefs Exp0) PassM [Exp0]
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 Exp0 -> FloatM Exp0
recur [Exp0]
ls
        TimeIt Exp0
e Ty0
ty IsBoxed
b    -> (\Exp0
a -> Exp0 -> Ty0 -> IsBoxed -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> IsBoxed -> PreExp ext loc dec
TimeIt Exp0
a Ty0
ty IsBoxed
b) (Exp0 -> Exp0) -> FloatM Exp0 -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> FloatM Exp0
recur Exp0
e
        WithArenaE Var
v Exp0
e -> (Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v) (Exp0 -> Exp0) -> FloatM Exp0 -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> FloatM Exp0
recur Exp0
e
        SpawnE Var
fn [Ty0]
tyapps [Exp0]
args -> (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
fn [Ty0]
tyapps) ([Exp0] -> Exp0)
-> StateT (FunDefs Exp0) PassM [Exp0] -> FloatM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> FloatM Exp0)
-> [Exp0] -> StateT (FunDefs Exp0) PassM [Exp0]
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 Exp0 -> FloatM Exp0
recur [Exp0]
args
        Exp0
SyncE   -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
        Ext{}   -> Exp0 -> FloatM Exp0
forall a. a -> StateT (FunDefs Exp0) PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
        MapE{}  -> [Char] -> FloatM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)
        FoldE{} -> [Char] -> FloatM Exp0
forall {a}. [Char] -> a
err1 (Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
ex)

      where
        recur :: Exp0 -> FloatM Exp0
recur = IsBoxed -> Env2 Ty0 -> Exp0 -> FloatM Exp0
go IsBoxed
float Env2 Ty0
env2