{-# LANGUAGE ParallelListComp #-} -- The Timber compiler -- -- Copyright 2008-2009 Johan Nordlander -- 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