timberc-1.0.3: src/Prepare4C.hs
{-# LANGUAGE ParallelListComp #-}
-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008-2009 Johan Nordlander <nordland@csee.ltu.se>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- 1. Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- 2. Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- 3. Neither the names of the copyright holder and any identified
-- contributors, nor the names of their affiliations, may be used to
-- endorse or promote products derived from this software without
-- specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
module Prepare4C(prepare4c) where
import Monad
import Common
import Kindle
import PP
import qualified Core
import qualified Core2Kindle
-- Establishes that:
-- every struct function simply relays all work to a global function with an explicit "this" parameter
-- every EEnter expression has a variable as its body
-- every ENew expression occurs at the rhs of a Val binding
-- Removes the type arguments from all type constructors except Array
-- Replaces type variables with the special type constructor POLY
-- Adds type casts wherever necessary
-- Replaces type abstraction and application with BITSET parameters indicating pointer/non-pointer status
-- Replaces nullary structs with out-of-band pointers (casts from the corresponding tag value)
-- Replaces type constructor switching by switching on integer tags (embedded as pointer values or as explicit tag fields)
-- Makes field selection from matched struct variants explicit
-- Removes CBreak commands that appear directly under a CSeq (without any intervening CSwitch)
-- Removes redundant defaults in CSwitch commands
-- (Not yet):
-- Flattens the struct subtyping graph by inlining the first coercion field
-- Ditto for enums...
prepare4c e2 e3 m = localStore (pModule e2 e3 m)
-- ===========================
-- Local environment
-- ===========================
data Env = Env { decls :: Decls, -- all structs in scope
tenv :: TEnv, -- all fun and val variables in scope
strinfo :: Map Name (Int,[Bool]), -- number of ptr fields + 1 / relevance flags of tvars for each struct
polyenv :: Map Name (Exp,Int), -- status location (refexp,bit-number) for type variables in scope
conval :: Map Name Int, -- numerical values of all variant constructor names
nulls :: [Name], -- lists all nullary struct variants
tagged :: [Name], -- lists all struct variants that use an explicit tag field
this :: Maybe Name }
env0 = Env { decls = [], tenv = [], strinfo = [], polyenv = [], conval = [], nulls = [], tagged = [], this = Nothing }
addDecls ds env = env { decls = ds ++ decls env, strinfo = info ++ strinfo env, conval = convals ++ conval env,
nulls = nullcons ++ nulls env, tagged = taggedcons ++ taggedunions ++ tagged env }
where unioncons = unions ds
allvariants = map (variants ds) unioncons
convals = concat (map (`zip` [0..]) allvariants)
nullcons = [ n | (n, Struct _ [] (Extends _)) <- ds ]
singlecons = map head . filter ((==1) . length) . map (\\nullcons) $ allvariants
taggedcons = dom convals \\ (singlecons++nullcons)
taggedunions = [ n | (n,ns) <- unioncons `zip` allvariants, any (`elem` taggedcons) ns ]
info = mapSnd structInfo ds
structInfo (Struct vs te _) = (length (ptrFields te []), map (`elem` relevant) vs)
where relevant = rng (varFields te)
addTEnv te env = env { tenv = te ++ tenv env }
addVals te env = env { tenv = mapSnd ValT te ++ tenv env }
addPolyEnv vs is es env = env { polyenv = mkPolyEnv vs is es ++ polyenv env }
-- Create a polyTag ATEnv on basis of polymorphic arity and return a mapping from each tyvar to its corresponding arg/bit
mkPolyEnv [] _ _ = []
mkPolyEnv (v:vs) (i:is) es = (v, (es!!(i`div`32), i`mod`32)) : mkPolyEnv vs is es
setThis x env = env { this = Just x }
findValT xx te x = t
where ValT t = lookup'' xx te x
findFunT te x ts = (vs `zip` ts, ts', t)
where FunT vs ts' t = lookup'' "B" te x
findStructTEnv xx env (TCon n ts)
| isTuple n = (abcSupply `zip` ts, abcSupply `zip` map (ValT . tVar) (take (width n) abcSupply))
| otherwise = (vs `zip` ts, te)
where Struct vs te _ = lookup'' xx (decls env) n
findStructInfo env n
| isTuple n = (width n + 1, take (width n) (repeat True))
| otherwise = lookup' (strinfo env) n
findPolyTag xx env v = lookup'' (xx ++ ": " ++ show (polyenv env)) (polyenv env) v
conLit env n = lInt (lookup'' "GGG" (conval env) n)
allCons env (ACon n _ _ _ : _)
| isTuple n = [n]
| otherwise = variants (decls env) n0
where Struct _ _ (Extends n0) = lookup'' "Apa" (decls env) n
allCons env _ = []
visibleArity env n = structArity ds (structRoot ds n)
where ds = decls env
-- =====================================
-- Replacing polymorphism with polyTags
-- =====================================
-- Create a list of polyTag types on basis of polymorphic arity
polyTagTypes 0 = []
polyTagTypes a | a <= 32 = [tBITS32]
| otherwise = tBITS32 : polyTagTypes (a-32)
-- Create a polyTag TEnv on basis of polymorphic arity (the externally visible part)
polyTagEnv0 a | a <= 4 = [(prim GCINFO, ValT tPOLY)]
| otherwise = (prim GCINFO, ValT tPOLY) :
_ABCSupply `zip` map ValT (polyTagTypes a)
-- Create a polyTag TEnv on basis of polymorphic arity (the existentially quantified part)
polyTagEnv1 a = _abcSupply `zip` map ValT (polyTagTypes a)
-- Create a polyTag struct binding from a list of type arguments
polyTagBinds env n ts = bs0 ++ bs1
where mkBind (x,ValT t) e = (x, Val t e)
ts0 = zipFilter vflags ts
ts1 = drop va ts
va = visibleArity env n
l_ts0 = length ts0
te0 = polyTagEnv0 l_ts0
es0 = polyTagArgs env ts0
bs0 | l_ts0 <= 4 = zipWith mkBind te0 [ECall (gcInfoName n) [] (map offset es0)]
| otherwise = zipWith mkBind te0 (ECall (gcInfoName n) [] [] : es0)
bs1 = zipWith mkBind (polyTagEnv1 (length ts1)) (polyTagArgs env ts1)
offset e = ECall (prim IntTimes) [] [ELit (lInt (d + 2)),e]
(d,vflags) = findStructInfo env n
gcInfoName n@(Name s t m a)
| isClosure n = Name (gcinfoSym ++ s) 0 m a
| okForC s = Name (gcinfoSym ++ s) t m a
| otherwise = Name (gcinfoSym ++ "_sym_" ++ show t) t m a
gcInfoName (Tuple n a) = Name (gcinfoSym ++ "TUP" ++ show n) 0 Nothing a
gcInfoName (Prim p a) = Name (gcinfoSym ++ strRep2 p) 0 Nothing a
-- Create a list of polyTag Exp arguments from a list of type arguments
polyTagArgs env [] = []
polyTagArgs env ts
| vars && ordered && total = [e0]
where vars = l_ts == length vs && length (nub es) == 1
l_ts = length ts
vs = [ n | TVar n _ <- ts ]
(es,is) = unzip (map (findPolyTag "XX" env) vs)
e0 = head es
ordered = is == [0..l_ts-1]
total = length [ v | (v,(e,_)) <- polyenv env, e == e0 ] == l_ts
polyTagArgs env ts = args (length ts) ts
where
args 0 [] = []
args a ts | a <= 32 = [arg 0 ts]
| otherwise = arg 0 ts0 : args (a-32) ts1
where (ts0,ts1) = splitAt a ts
arg k [] = intlit 0
arg k (TVar n _ : ts) = bor (arg (k+1) ts) (shift (band e (mask i)) i k)
where (e,i) = findPolyTag "YY" env n
arg k (TCon (Prim p _) _ : ts)
| p `elem` scalarPrims = bor (mask k) (arg (k+1) ts)
arg k (_ : ts) = arg (k+1) ts
shift e i k | i < k = shiftL e (ELit (lInt (k-i)))
| i > k = shiftR e (ELit (lInt (i-k)))
| otherwise = e
shiftL e1 e2 = ECall (prim SHIFTL32) [] [e1,e2]
shiftR e1 e2 = ECall (prim SHIFTR32) [] [e1,e2]
mask i = intlit (2^i)
bor e1 e2 | e1 == intlit 0 = e2
| e2 == intlit 0 = e1
| otherwise = ECall (prim OR32) [] [e1,e2]
band e1 e2 = ECall (prim AND32) [] [e1,e2]
intlit i = ECast tBITS32 (ELit (lInt i))
-- =============================
-- Prepare modules and types
-- =============================
pModule e2 dsi (Module m ns ds bs)
= do -- tr (render (vcat (map pr dsi))
let (_,_,_,Core.Binds _ te2 _) = e2
tei <- Core2Kindle.c2kTEnv dsi te2
let env1 = addTEnv (primTEnv++tei) (addDecls (primDecls++dsi) env0)
env = addTEnv (mapSnd typeOf bs) (addDecls ds env1)
(bf,bs) <- pBinds pBind env bs
bs' <- currentStore
return (Module m ns (pDecls env ds) (gcinfo env ds ++ flatBinds bf ++ bs ++ reverse bs'))
-- Prepare structs declarations
pDecls env ds = map f ds
where f (n,Struct vs te _) = (n, Struct [] (polyTagEnv0 l_vs0 ++ tagSig ++ mapSnd pType te ++ polyTagEnv1 l_vs1) Top)
where tagSig = if n `elem` tagged env then [(prim Tag, ValT tInt)] else []
l_vs0 = length (zipFilter vflags vs)
l_vs1 = length (drop va vs)
va = visibleArity env n
(_,vflags) = findStructInfo env n
-- gcinfo types: these must match corresponding defines in gc.c
gcSTD = ELit (lInt 0)
gcARRAY = ELit (lInt 1)
gcTUPLE = ELit (lInt 2)
gcBIG = ELit (lInt 3)
gcMUT = ELit (lInt 4)
-- Generate gcinfo for structs
gcinfo env ds = map f (prune ds (nulls env))
where f (n,Struct vs te cs) = (gcInfoName n, Val tPOLY (ECall (prim GCINFO) [] es))
where es | l_vs1 <= 4 = concat [ EVar n : gcSTD : pad l_es0 (ptrFields te vs) | vs <- sampleSpaces vs1 ]
| otherwise = EVar n : gcBIG : es0 ++ concat (map bitRef (varFields te)) ++ [ELit (lInt 0)]
es0 = ptrFields te []
l_es0 = length es0
(d,vflags) = findStructInfo env n
vs1 = zipFilter vflags vs
l_vs1 = length vs1
idx = vs1 `zip` [0..]
bitRef (n,v) = [ EVar n, ELit (lInt (i `div` 32 + 1)), ELit (lInt (i `mod` 32)) ]
where i = lookup'' "DDD" idx v
pad n es = es ++ replicate (n - length es) (ELit (lInt 0))
ptrFields te vs = map EVar (dom (filter (isPtr vs) te)) ++ [ELit (lInt 0)]
sampleSpaces [] = [[]]
sampleSpaces (v:vs) = [ vs1 ++ vs2 | vs1 <- [[],[v]], vs2 <- sampleSpaces vs ]
isPtr vs (n,FunT _ _ _) = False
isPtr vs (n,ValT (TVar v _)) = v `notElem` vs
isPtr vs (Prim Next _, _) = False -- the next field in Msg and its subtypes is custom handled during timerQ scanning.
isPtr vs (n,ValT (TCon k _)) = not (isScalar k)
isScalar (Prim p _) = p `elem` scalarPrims
isScalar n = False
varFields te = [ (n,v) | (n,ValT (TVar v _)) <- te ]
-- Simplify types
pType (ValT t) = ValT (erase t)
pType (FunT vs ts t) = FunT [] (polyTagTypes (length vs) ++ map erase ts) (erase t)
-- Erase polymorphism from atomic types
erase (TCon n _) = TCon n []
erase (TVar _ _) = tPOLY
eraseEnv te = mapSnd erase te
-- =============================
-- Prepare bindings and commands
-- =============================
-- Prepare bindings
pBinds f env xs = do (bfs,xs) <- fmap unzip (mapM (f env) xs)
return (foldr (.) id bfs, xs)
-- Prepare top-level & cmd bindings (assume code is lambda-lifted)
pBind env (x, Val t e) = do (bf,t',e) <- pRhsExp env e
return (bf, (x, Val (erase t) (cast t t' e)))
pBind env (x, Fun vs t te c) = do te' <- newEnv paramSym (polyTagTypes (length vs))
c <- pCmd (addVals te (addPolyEnv vs [0..] (map EVar (dom te')) env)) t c
return (id, (x, Fun [] (erase t) (te' ++ eraseEnv te) c))
-- Prepare struct bindings (assume code is lambda-lifted)
pSBind _ te0 env (x,Val t e) = do (bf,e) <- pExpT env t e
return (bf, (x, Val (erase t0) (cast t0 t e)))
where t0 = findValT "1" te0 x
pSBind _ te0 env (x,Fun [] t te c@(CRet (ECall f [] (EThis:es))))
| okAlready = return (id, (x, Fun [] t te c))
where (_,ts0,t0) = findFunT te0 x []
okAlready = t == erase t0 && rng te == map erase ts0 && es == map EVar (dom te)
pSBind ty te0 env (x,Fun vs t te c)
= do y <- newName thisSym
te0 <- newEnv paramSym ts0
te' <- newEnv paramSym (polyTagTypes (length vs))
let bs0 = [ (x, Val t (cast t t0 (EVar x0))) | (x0,t0) <- te0 | (x,t) <- te ]
te1 = [ if isEVar e then (x,t) else xt0 | (x, Val t e) <- bs0 | xt0 <- te0 ]
bs1 = [ b | b@(_,Val _ e) <- bs0, not (isEVar e) ]
te1' = te' ++ eraseEnv te1
env' = addPolyEnv vs [0..] (map EVar (dom te')) (rebindPolyEnv ty y env)
c <- pCmd (setThis y (addVals ((y,ty):te) env')) t0 c
f <- newName functionSym
addToStore (f, Fun [] t0' ((y,erase ty):te1') (cBind bs1 c))
return (id, (x, Fun [] t0' te1' (CRet (ECall f [] (EThis : map EVar (dom te1'))))))
where (_,ts0,t0) = findFunT te0 x []
t0' = erase t0
rebindPolyEnv (TCon n ts) y env = addPolyEnv vs is (map (ESel (EVar y)) _abcSupply) env
where ts1 = drop (visibleArity env n) ts
(vs,is) = unzip [ (v,i) | (TVar v _, i) <- ts1 `zip` [0..] ]
-- Prepare commands
pCmd env t0 (CRet e) = do (bf,e) <- pExpT env t0 e
return (bf (CRet e))
pCmd env t0 (CRun e c) = do (bf,_,e) <- pExp env e
liftM (bf . CRun e) (pCmd env t0 c)
pCmd env t0 (CBind _ [] c) = pCmd env t0 c
pCmd env t0 (CBind False bs c) = do (bf,bs) <- pBinds pBind env bs
liftM (bf . CBind False bs) (pCmd env' t0 c)
where env' = addTEnv (mapSnd typeOf bs) env
pCmd env t0 (CBind True bs c) = do (bf,bs) <- pBinds pBind env' bs
liftM (CBind True (flatBinds bf ++ bs)) (pCmd env' t0 c)
where env' = addTEnv (mapSnd typeOf bs) env
pCmd env t0 (CUpd x e c) = do (bf,e) <- pExpT env (findValT "2" (tenv env) x) e
liftM (bf . CUpd x e) (pCmd env t0 c)
pCmd env t0 (CUpdS e x e' c) = do (bf,t1,e) <- pExp env e
let (s,te) = findStructTEnv "AA" env t1
(bf',e') <- pExpT env (findValT "3" te x) e'
liftM (bf . bf' . CUpdS e x e') (pCmd env t0 c)
pCmd env t0 (CUpdA e i e' c) = do (bf,TCon (Prim Array _) [t],e) <- pExp env e
(bf',i) <- pExpT env tInt i
(bf'',e') <- pExpT env tPOLY e'
liftM (bf . bf' . bf'' . CUpdA e i e') (pCmd env t0 c)
pCmd env t0 (CSeq c c') = liftM2 mkSeq (pCmd env t0 c) (pCmd env t0 c')
pCmd env t0 (CBreak) = return CBreak
pCmd env t0 (CRaise e) = do (bf,e) <- pExpT env tInt e
return (bf (CRaise e))
pCmd env t0 (CWhile e c c') = do (bf,e) <- pExpT env tBool e
c <- pCmd env t0 c
liftM (bf . CWhile e c) (pCmd env t0 c')
pCmd env t0 (CCont) = return CCont
pCmd env t0 (CSwitch e alts)
| any litA alts = if simple (litType (firstLit alts)) then
do (bf,e) <- pExpT env tInt e
alts <- mapM (pAlt env e tInt t0) alts
return (bf (CSwitch e alts))
else mkVarSwitch env t0 e alts
| isEVar e || all nullA alts = do (bf,t,e) <- pExp env e
alts <- mapM (pAlt env e t t0) alts
let (alts0,alts1) = partition nullA [ a | a@(ACon _ _ _ _) <- alts ]
altsW = [ a | a@(AWild _) <- alts ]
return (bf (mkSwitch env e (alts0++absent0 altsW) (alts1++absent1 altsW)))
| otherwise = mkVarSwitch env t0 e alts
where nullA (ACon k _ _ _) = k `elem` nulls env
nullA _ = False
absent = allCons env alts \\ [ k | ACon k _ _ _ <- alts ]
(abs0,abs1) = partition (`elem` nulls env) absent
absent0 [] = [ ACon k [] [] CBreak | k <- abs0 ]
absent0 (AWild d : _) = [ ACon k [] [] d | k <- abs0 ]
absent1 altsW = [ a | a <- altsW, not (null abs1) ]
litA (ALit _ _) = True
litA _ = False
firstLit (ALit l _ : _) = l
firstLit (_ : as) = firstLit as
simple (TCon (Prim Int _) []) = True
simple (TCon (Prim Char _) []) = True
simple _ = False
mkSwitch env (EVar _) [] [] = CBreak
mkSwitch env e [] [] = CSwitch e [AWild CBreak]
mkSwitch env e [] [ACon n _ _ c]
| n `notElem` tagged env = c
mkSwitch env e [] [AWild c] = c
mkSwitch env e [] alts1 = CSwitch (ESel e (prim Tag)) (map (mkLitAlt env) alts1)
mkSwitch env e alts0@[ACon n _ _ c] []
| allCons env alts0 == [n] = c
mkSwitch env e alts0 [] = CSwitch (ECast tInt e) (map (mkLitAlt env) alts0)
mkSwitch env e alts0 alts1 = mkSwitch env e (alts0++[AWild d]) []
where d = mkSwitch env e [] alts1
mkVarSwitch env t0 e alts
| isEVar e = do (bf,t,e) <- pExp env e
alts <- mapM (pAlt env e t t0) alts
return (bf (CSwitch e alts))
| otherwise = do (bf,t,e) <- pExp env e
x <- newName tempSym
c <- pCmd (addVals [(x,t)] env) t0 (CSwitch (EVar x) alts)
return (bf (cBind [(x,Val t e)] c))
mkLitAlt env (ACon n [] [] c) = ALit (conLit env n) c
mkLitAlt env a = a
-- Prepare switch alternatives
pAlt env _ _ t0 (AWild c) = liftM AWild (pCmd env t0 c)
pAlt env _ _ t0 (ALit l c) = liftM (ALit l) (pCmd env t0 c)
pAlt env e (TCon _ ts) t0 (ACon k vs te c)
= do te' <- newEnv paramSym (polyTagTypes (length vs))
c <- pCmd (addPolyEnv vs [0..] (map EVar (dom te')) (addVals te env)) t0 c
return (ACon k [] [] (cBind (bs0 te' ++ bs1) c))
where bs0 te = zipWith mkBind te (_abcSupply `zip` repeat (ValT tBITS32))
(_,te0) = findStructTEnv "KKK" env (TCon k (ts ++ map tVar vs))
bs1 = filter (not . isDummy . fst) (zipWith mkBind te te0)
mkBind (x,t) (y,ValT u) = (x, Val t (cast t u (ESel (ECast (TCon k (ts ++ map tVar vs)) e) y)))
mkSeq c1 c2 = case anchor c1 of
(bf,CBreak) -> bf c2
(bf,CCont) -> c1
_ -> CSeq c1 c2
where anchor (CBind r bs c) = (CBind r bs . bf, c')
where (bf,c') = anchor c
anchor (CRun e c) = (CRun e . bf, c')
where (bf,c') = anchor c
anchor (CUpd x e c) = (CUpd x e . bf, c')
where (bf,c') = anchor c
anchor (CUpdS e x e' c) = (CUpdS e x e' . bf, c')
where (bf,c') = anchor c
anchor (CUpdA e i e' c) = (CUpdA e i e' . bf, c')
where (bf,c') = anchor c
anchor c = (id, c)
-- =============================
-- Prepare expressions
-- =============================
-- Prepare a right-hand-side expression
pRhsExp env (ENew n ts bs) = pNewExp env n ts bs
pRhsExp env (ECast t (ENew n ts bs))
= do (bf,t',e) <- pNewExp env n ts bs
return (bf, t, cast t t' e)
pRhsExp env e = pExp env e
pNewExp env n ts bs
| n `elem` nulls env = return (id, t0, cast t0 tInt (ELit (conLit env n)))
| otherwise = do (bf,bs) <- pBinds (pSBind t0 te0) env bs
return (bf, t0, ENew n [] (bs''++bs'++bs))
where bs' = if n `elem` tagged env then [(prim Tag, Val tInt (ELit (conLit env n)))] else []
bs'' = polyTagBinds env n ts
t0 = TCon n ts
(_,te0) = findStructTEnv "BB" env t0
pRefBind te0 env (x,Val _ e) = do (bf,t,e) <- pRhsExp env e
return (bf, (x, Val (erase t0) (cast t0 t e)))
where t0 = findValT "1" te0 x
-- Prepare an expression in an arbitrary position and match its type with the expected one
pExpT env t0 e = do (bf,t,e) <- pExp env e
return (bf, cast t0 t e)
cast t0 t1 e
| u0 == u1 = e
| u0 == tPOLY && smallPrim u1 = ECast tPOLY (ECast tInt e)
| smallPrim u0 && u1 == tPOLY = ECast u0 (ECast tInt e)
| u0 == tPOLY && u1 == tFloat = ECall (prim Float2POLY) [] [e]
| u0 == tFloat && u1 == tPOLY = ECall (prim POLY2Float) [] [e]
| otherwise = ECast u0 e
where u0 = erase t0
u1 = erase t1
smallPrim (TCon (Prim p _) _) = p `elem` smallPrims
smallPrim _ = False
pExpTs env [] [] = return (id, [])
pExpTs env (t:ts) (e:es) = do (bf1,e) <- pExpT env t e
(bf2,es) <- pExpTs env ts es
return (bf1 . bf2, e:es)
-- Prepare an expression in an arbitrary position and compute its type
pExp env (EVar x) = return (id, findValT "4" (tenv env) x, EVar x)
pExp env (ELit l) = return (id, litType l, ELit l)
pExp env (EThis) = return (id, findValT "5" (tenv env) x, EVar x)
where x = fromJust (this env)
pExp env (ESel e l) = do (bf,t1,e) <- pExp env e
let (s,te) = findStructTEnv "CC" env t1
t = findValT ("6" ++ " e: " ++ render (pr e) ++ " te: " ++ show te) te l
specialize s t bf (ESel e l)
pExp env (ECall f ts es) = do (bf,es) <- pExpTs env ts0 es
specialize s t bf (ECall f [] (polyTagArgs env ts ++ es))
where (s,ts0,t) = findFunT (tenv env) f ts
pExp env (EEnter (EVar x) f ts es) = do let t1 = findValT "7" (tenv env) x
let (s,te) = findStructTEnv "DD" env t1
(s',ts0,t) = findFunT te f ts
(bf,es) <- pExpTs env ts0 es
specialize (s'@@s) t bf (EEnter (EVar x) f [] (polyTagArgs env ts ++ es))
pExp env (EEnter e f ts es) = do (bf1,t1,e) <- pRhsExp env e
let (s,te) = findStructTEnv "EE" env t1
(s',ts0,t) = findFunT te f ts
(bf2,es) <- pExpTs env ts0 es
x <- newName tempSym
specialize (s'@@s) t (bf1 . bf2 . cBind [(x, Val (erase t1) e)]) (EEnter (EVar x) f [] (polyTagArgs env ts ++ es))
pExp env (ECast t e) = do (bf,t',e) <- pExp env e
return (bf, t, cast t t' e)
pExp env (ENew n ts bs)
| n `elem` nulls env = return (id, tInt, ELit (conLit env n))
| otherwise = do (bf,t,e) <- pNewExp env n ts bs
x <- newName tempSym
return (bf . cBind [(x, Val (erase t) e)], t, EVar x)
specialize s t bf e = return (bf, t', cast t' t e)
where t' = subst s t