implementation module Sil.Compile

import StdBool
import StdEnum
from StdFunc import const, flip, o
import StdList
import StdMisc
import StdString

import Control.Applicative
import Control.Monad
import Control.Monad.RWST
import Control.Monad.Trans
import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Tuple
from Text import <+

import qualified ABC.Assembler as ABC

import Sil.Error
import Sil.Syntax
import Sil.Types
import Sil.Util.Printer

error :: Error -> RWST r w s (MaybeError Error) a
error e = RWST \_ _ -> Error e

nop :: RWST r w s m () | Monoid w & Monad m
nop = RWST \_ s -> pure ((), s, mempty)

compile :: Program -> MaybeError Error 'ABC'.Assembler
compile prog = case evalRWST (censor censor` $ gen prog) () zero of
	Error e  -> Error e
	Ok (_,p) -> Ok p
where
	censor` = opt o filter isUseful

	opt :: 'ABC'.Assembler -> 'ABC'.Assembler
	// Equality checks for integers
	opt ['ABC'.PushI i:'ABC'.Push_b l:'ABC'.EqI:ss] = ['ABC'.EqI_b i (l-1):opt ss]
	opt ['ABC'.Push_b l:'ABC'.PushI i:'ABC'.EqI:ss] = ['ABC'.EqI_b i l    :opt ss]
	// Delay pushing if we need to pop
	opt ['ABC'.PushI i:'ABC'.Update_b 0 l:'ABC'.Pop_b n:ss] | l == n = ['ABC'.Pop_b n:'ABC'.PushI i:opt ss]
	// Combine pops
	opt ['ABC'.Pop_a i:'ABC'.Pop_a j:ss] = opt ['ABC'.Pop_a (i+j):ss]
	opt ['ABC'.Pop_b i:'ABC'.Pop_b j:ss] = opt ['ABC'.Pop_b (i+j):ss]
	// Remove unreachable code
	opt ['ABC'.Rtn:ss] = ['ABC'.Rtn:opt $ skipUntilEntryPoint ss]
	opt ['ABC'.Jmp l:ss] = ['ABC'.Jmp l:opt $ skipUntilEntryPoint ss]
	// Remove needless moves between A and B stacks
	opt ['ABC'.PushI_a 0:'ABC'.Pop_a 1:'ABC'.Create:'ABC'.FillI_b 0 0:'ABC'.Pop_b 1:ss] = opt ss
	opt ['ABC'.PushB_a 0:'ABC'.Pop_a 1:'ABC'.Create:'ABC'.FillB_b 0 0:'ABC'.Pop_b 1:ss] = opt ss
	// Base cases
	opt [s:ss] = [s:opt ss]
	opt []     = []

	isUseful :: 'ABC'.Statement -> Bool
	isUseful ('ABC'.Pop_a 0)      = False
	isUseful ('ABC'.Pop_b 0)      = False
	isUseful ('ABC'.Update_a i j) = i <> j
	isUseful ('ABC'.Update_b i j) = i <> j
	isUseful ('ABC'.Comment _)    = False
	isUseful _                    = True

	skipUntilEntryPoint :: 'ABC'.Assembler -> 'ABC'.Assembler
	skipUntilEntryPoint ss=:[_:_]
	| all (\t -> t =: ('ABC'.Annotation _)) before = ss
	| otherwise                                    = skipUntilEntryPoint $ tl ss
	where
		(before,after) = span (not o (\t -> t =: ('ABC'.Label _))) ss
	skipUntilEntryPoint [] = []

:: Address
	= AAddr Int
	| BAddr Int

instance toString Address
where
	toString (AAddr i) = "A:" <+ i
	toString (BAddr i) = "B:" <+ i

:: FunctionSymbol =
	{ fs_arity    :: Int
	, fs_argtypes :: [Type]
	, fs_rettype  :: Type
	}

:: CompileState =
	{ labels        :: ['ABC'.Label]
	, addresses     :: 'M'.Map Name Address
	, symbols       :: 'M'.Map Name FunctionSymbol
	, returns       :: ['ABC'.Assembler]
	, returnType    :: Type
	, stackoffsets  :: (Int, Int) // A and B stack
	, storedoffsets :: [(Int, Int)]
	, typeresolvers :: [TypeResolver]
	}

instance zero CompileState
where
	zero =
		{ labels        = ["_l" <+ i \\ i <- [0..]]
		, addresses     = 'M'.newMap
		, symbols       = 'M'.newMap
		, returns       = []
		, returnType    = TVoid
		, stackoffsets  = (0, 0)
		, storedoffsets = []
		, typeresolvers = []
		}

labels :: CompileState -> ['ABC'.Label]
labels cs = cs.labels

addresses :: CompileState -> 'M'.Map Name Address
addresses cs = cs.addresses

symbols :: CompileState -> 'M'.Map Name FunctionSymbol
symbols cs = cs.symbols

peekReturn :: CompileState -> 'ABC'.Assembler
peekReturn cs = hd cs.returns

returnType :: CompileState -> Type
returnType cs = cs.returnType

stackoffsets :: CompileState -> (Int, Int)
stackoffsets cs = cs.stackoffsets

typeresolvers :: CompileState -> [TypeResolver]
typeresolvers cs = cs.typeresolvers

:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError Error) a

fresh :: a -> Gen 'ABC'.Label | toString a
fresh n = gets labels
	>>= \labs -> modify (\cs -> {cs & labels=tl labs})
	$> toLabel (n <+ hd labs)

storeStackOffsets :: Gen ()
storeStackOffsets = modify \cs -> {cs & storedoffsets=[cs.stackoffsets:cs.storedoffsets]}

restoreStackOffsets :: Gen ()
restoreStackOffsets = modify \cs=:{storedoffsets=[so:sos]} -> {cs & stackoffsets=so, storedoffsets=sos}

newReturn :: 'ABC'.Assembler -> Gen ()
newReturn ret = modify \cs -> {cs & returns=[ret:cs.returns]}

addToReturn :: 'ABC'.Assembler -> Gen ()
addToReturn ret = modify \cs=:{returns=[r:rs]} -> {cs & returns=[ret ++ r:rs]}

removeFromReturn :: Int -> Gen ()
removeFromReturn i = modify \cs=:{returns=[r:rs]} -> {cs & returns=[drop i r:rs]}

popReturn :: Gen ()
popReturn = modify \cs -> {cs & returns=tl cs.returns}

setReturnType :: Type -> Gen ()
setReturnType t = modify \cs -> {cs & returnType=t}

pushTypeResolver :: TypeResolver -> Gen ()
pushTypeResolver tr = modify \cs -> {cs & typeresolvers=[tr:cs.typeresolvers]}

popTypeResolver :: Gen ()
popTypeResolver = modify \cs -> {cs & typeresolvers=tl cs.typeresolvers}

getTypeResolver :: Gen TypeResolver
getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n ->
	case catMaybes $ map (flip ($) n) trs of
		[t:_] -> Just t
		[]    -> Nothing

reserveVar :: (Name, Type) -> Gen Address
reserveVar (n,t) = gets stackoffsets >>= put
where
	put :: (Int, Int) -> Gen Address
	put (aso, bso) =
		modify (\cs -> {cs & addresses='M'.put n addr cs.addresses, stackoffsets=so`}) *>
		comment ("Reserved " <+ addr <+ " for " <+ n) $>
		addr
	where
		(so`, addr) = case typeSize t of
			{asize,bsize=0} -> ((aso + asize, bso), AAddr $ aso + asize)
			{asize=0,bsize} -> ((aso, bso + bsize), BAddr $ bso + bsize)

findVar :: Name -> Gen Address
findVar n = gets stackoffsets >>= \(aso, bso) ->
	gets addresses >>= \addr -> case 'M'.get n addr of
		Just (AAddr i) -> comment (n <+ " is on AStack at " <+ i <+ ", with aso " <+ aso <+ " so " <+ (aso-i)) $> AAddr (aso - i)
		Just (BAddr i) -> comment (n <+ " is on BStack at " <+ i <+ ", with bso " <+ bso <+ " so " <+ (bso-i)) $> BAddr (bso - i)
		Nothing        -> error $ C_UndefinedName n

addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
where
	fs = { fs_arity    = length f.f_args
	     , fs_argtypes = [a.arg_type \\ a <- f.f_args]
	     , fs_rettype  = f.f_type
	     }

cleanup :: Gen ()
cleanup = gets peekReturn >>= tell

growStack :: TypeSize -> Gen ()
growStack {asize,bsize} =
	modify (\cs -> {cs & stackoffsets=update cs.stackoffsets}) *>
	gets stackoffsets >>= \(aso,bso) ->
	comment ("Stack offsets: (" <+ aso <+ ", " <+ bso <+ ")")
where
	update = appFst ((+) asize) o appSnd ((+) bsize)

shrinkStack :: (TypeSize -> Gen ())
shrinkStack = growStack o invert
where
	invert :: TypeSize -> TypeSize
	invert ts = {zero & asize=0-ts.asize, bsize=0-ts.bsize}

getType :: Expression -> Gen Type
getType e = getTypeResolver >>= \tr -> case type tr e of
	Nothing          -> error $ C_CouldNotDeduceType e
	Just (Error err) -> error err
	Just (Ok t)      -> pure $ t

checkType :: Type Expression -> Gen ()
checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e t`)

checkTypeName :: Name Expression -> Gen Type
checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`

tellAbort :: String -> Gen ()
tellAbort s = tell
	[ 'ABC'.Raw $ "\tbuildAC\t\"" <+ quote s <+ "\\r\\n\""
	, 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
	, 'ABC'.Jsr "print_string_"
	, 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
	, 'ABC'.Halt
	]
where
	quote :: (String -> String)
	quote = toString o q o fromString
	where
		q :: [Char] -> [Char]
		q [] = []
		q ['\\':cs] = ['\\':'\\':q cs]
		q ['\r':cs] = ['\\':'r' :q cs]
		q ['\n':cs] = ['\\':'n' :q cs]
		q ['\t':cs] = ['\\':'t' :q cs]
		q [c:cs]    = [c        :q cs]

class gen a :: a -> Gen ()

instance gen Program
where
	gen p =
		tell [ 'ABC'.Annotation $ 'ABC'.RawAnnot ["comp", "920", "01011101001"]
		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["start", "__sil_boot"]
		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["endinfo"]
		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["module", "m_sil_compiled", "\"sil_compiled\""]
		     , 'ABC'.Label "__sil_boot"
		     , 'ABC'.Create
		     , 'ABC'.Fill "_" 0 (toLabel "main") 0
		     , 'ABC'.Jmp "_driver"
		     ] *>
		pushTypeResolver typeresolver *>
		mapM_ addFunction p.p_funs *>
		mapM_ gen p.p_funs *>
		popTypeResolver
	where
		typeresolver :: Name -> Maybe (MaybeError Error Type)
		typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
			[]    -> Nothing
			[f:_] -> type zero f

instance gen Function
where
	gen f =
		tell [ 'ABC'.Annotation $ toOAnnot` [typeSize a.arg_type \\ a <- f.f_args]
		     , 'ABC'.Label $ toLabel f.f_name
		     ] *>
		tell (repeatn retSize.asize 'ABC'.Create) *>
		mapM_ reserveVar [(a.arg_name, a.arg_type) \\ a <- f.f_args] *>
		growStack {retSize & bsize=0} *>
		newReturn cleanup` *>
		pushTypeResolver typeresolver *>
		setReturnType f.f_type *>
		mainBootstrap *>
		gen f.f_code *>
		popTypeResolver *>
		cleanup *>
		modify (\cs -> {cs & stackoffsets=(0, 0)}) *> comment "Reset sos" *>
		tell ['ABC'.Rtn] *>
		popReturn
	where
		cleanup` =
			[ 'ABC'.Comment "Cleanup"
			, 'ABC'.Pop_a (foldr (+~) zero [typeSize a.arg_type \\ a <- f.f_args]).asize
			, 'ABC'.Pop_b (foldr (+~) zero [typeSize a.arg_type \\ a <- f.f_args]).bsize
			, 'ABC'.Annotation $ toDAnnot retSize
			]
		retSize = typeSize f.f_type

		typeresolver :: Name -> Maybe (MaybeError Error Type)
		typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n]

		mainBootstrap :: Gen ()
		mainBootstrap
		| f.f_name == "main"
			| (typeSize f.f_type).bsize == 1 =
				fresh "main" >>= \lab ->
				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot 0 []
				     , 'ABC'.Jsr lab
				     , 'ABC'.Annotation $ toOAnnot $ typeSize f.f_type
				     ] *>
				BtoAStack type *>
				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
				     , 'ABC'.Rtn
				     ] *>
				comment "Reset sos" *>
				modify (\cs -> {cs & stackoffsets=(0, 0)}) *>
				tell [ 'ABC'.Label lab ]
				with
					type = case f.f_type of
						TBool -> 'ABC'.BT_Bool
						TInt  -> 'ABC'.BT_Int
			| f.f_type == TVoid =
				fresh "main" >>= \lab ->
				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot 0 []
				     , 'ABC'.Jsr lab
				     , 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
				     , 'ABC'.Raw "\tbuildh e__predef_d_Unit 0"
				     , 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
				     , 'ABC'.Rtn
				     ] *>
				comment "Reset sos" *>
				modify (\cs -> {cs & stackoffsets=(0, 0)}) *>
				tell [ 'ABC'.Label lab ]
			| otherwise = nop
		| otherwise = nop

instance gen CodeBlock
where
	gen cb =
		storeStackOffsets *>
		gets stackoffsets >>= \so ->
		mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- cb.cb_init] *>
		mapM_ gen cb.cb_init *>
		addToReturn cleanup` *>
		pushTypeResolver typeresolver *>
		mapM_ gen cb.cb_content *>
		popTypeResolver *>
		tell cleanup` *>
		removeFromReturn (length cleanup`) *>
		restoreStackOffsets
	where
		cleanup` = case cb.cb_init of
			[] -> []
			_  -> [ 'ABC'.Pop_a locals.asize
			      , 'ABC'.Pop_b locals.bsize
			      ]
		locals = foldr (+~) zero [typeSize i.init_type \\ i <- cb.cb_init]

		typeresolver :: Name -> Maybe (MaybeError Error Type)
		typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n]

instance gen Initialisation
where
	gen init = case typeSize init.init_type of
		s=:{bsize=0} -> tell $ repeatn s.asize 'ABC'.Create
		s=:{asize=0} -> case init.init_value of
			Nothing -> error $ C_BasicInitWithoutValue init.init_name
			Just v  -> checkType init.init_type v *> gen v *> shrinkStack s

instance gen Statement
where
	gen st=:(Declaration n e) =
		checkTypeName n e >>= \t ->
		comment (toString st) *>
		gen e *>
		findVar n >>=
		updateLoc t
	where
		updateLoc :: Type Address -> Gen ()
		updateLoc t (AAddr i) = case (typeSize t, t) of
			// TODO should depend on size of return type
			({asize=0}, TInt)  -> tell ['ABC'.FillI_b 0 i,  'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1}
			({asize=0}, TBool) -> tell ['ABC'.FillB_b 0 i,  'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1}
			_                  -> tell ['ABC'.Update_a 0 i, 'ABC'.Pop_a 1] *> shrinkStack {zero & asize=1}
		updateLoc _ (BAddr i)  =  tell ['ABC'.Update_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1}
	gen (Application e) =
		comment "Application" *>
		gen e *>
		getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of
			Just (Ok sz)     -> tell ['ABC'.Pop_a sz.asize, 'ABC'.Pop_b sz.bsize] *> shrinkStack sz
			Just (Error err) -> error err
			Nothing          -> error $ C_CouldNotDeduceType e
	gen (Return (Just e)) =
		comment "Return" *>
		gen e *>
		gets returnType >>= \rettype ->
		comment ("Checking type " <+ rettype <+ " on " <+ e <+ "...") *>
		checkType rettype e *>
		gets stackoffsets >>= \so ->
		updateReturnFrame (typeSize rettype) so *>
		shrinkStack (typeSize rettype) *>
		cleanup *>
		tell ['ABC'.Rtn]
	where
		updateReturnFrame :: TypeSize (Int, Int) -> Gen ()
		updateReturnFrame {asize=0,bsize=0} _ = nop
		updateReturnFrame {bsize=0} (aso, _)  = tell ['ABC'.Update_a 0 (aso-1), 'ABC'.Pop_a 1] // TODO should depend on return type
		updateReturnFrame _         (_, bso)  = tell ['ABC'.Update_b 0 (bso-1)] // TODO should depend on return type
	gen (Return Nothing) =
		comment "Return" *>
		cleanup *>
		tell ['ABC'.Rtn]
	gen (MachineStm s) =
		tell ['ABC'.Raw s]
	gen (If blocks else) =
		fresh "ifend" >>= \end ->
		mapM_ (genifblock end) blocks *>
		genelse end else
	where
		genifblock :: 'ABC'.Label (Expression, CodeBlock) -> Gen ()
		genifblock end (cond, cb) =
			checkType TBool cond *>
			fresh "ifelse" >>= \else ->
			comment ("(else) if " <+ cond) *>
			gen cond *>
			tell [ 'ABC'.JmpFalse else ] *>
			shrinkStack {zero & bsize=1} *>
			gen cb *>
			tell [ 'ABC'.Jmp end
			     , 'ABC'.Label else ]

		genelse :: 'ABC'.Label (Maybe CodeBlock) -> Gen ()
		genelse end Nothing   = tell ['ABC'.Label end]
		genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
	gen (While cond do) =
		checkType TBool cond *>
		fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
		tell [ 'ABC'.Label loop ] *>
		gen cond *>
		tell [ 'ABC'.JmpFalse end ] *>
		shrinkStack {zero & bsize=1} *>
		gen do *>
		tell [ 'ABC'.Jmp loop
		     , 'ABC'.Label end ]

instance gen Expression
where
	gen (Name n) = findVar n >>= getLoc
	where
		getLoc :: Address -> Gen ()
		getLoc (AAddr i) = tell ['ABC'.Push_a $ i] *> growStack {zero & asize=1}
		getLoc (BAddr i) = tell ['ABC'.Push_b $ i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} //TODO check type
	gen (Literal (BLit b)) =
		tell ['ABC'.PushB b] *>
		growStack {zero & bsize=1,btypes=['ABC'.BT_Bool]}
	gen (Literal (ILit i)) =
		tell ['ABC'.PushI i] *>
		growStack {zero & bsize=1,btypes=['ABC'.BT_Int]}
	gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just i -> error C_FunctionOnStack
		_      -> gets symbols >>= \syms -> case 'M'.get n syms of
			Just fs ->
				comment "Retrieve arguments" *>
				mapM gen args *>
				comment "Apply function" *>
				tell [ 'ABC'.Annotation $ toDAnnot` $ map typeSize fs.fs_argtypes
				     , 'ABC'.Jsr $ toLabel n
				     , 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype
				     ] *>
				growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes)
			_ -> error $ C_UndefinedName n
	gen (BuiltinApp op arg) =
		gen arg *>
		gen op
	gen (BuiltinApp2 e1 LogOr e2) =
		checkType TBool e1 *>
		checkType TBool e2 *>
		fresh "or_true" >>= \true ->
		fresh "or_end" >>= \end ->
		storeStackOffsets *>
		gen e1 *>
		tell [ 'ABC'.JmpTrue true ] *>
		gen e2 *>
		tell [ 'ABC'.Jmp end ] *>
		restoreStackOffsets *>
		tell [ 'ABC'.Label true
		     , 'ABC'.PushB True ] *>
		growStack {zero & bsize=1} *>
		tell [ 'ABC'.Label end ]
	gen (BuiltinApp2 e1 LogAnd e2) =
		checkType TBool e1 *>
		checkType TBool e2 *>
		fresh "and_false" >>= \false ->
		fresh "and_end" >>= \end ->
		storeStackOffsets *>
		gen e1 *>
		tell [ 'ABC'.JmpFalse false ] *>
		gen e2 *>
		tell [ 'ABC'.Jmp end ] *>
		restoreStackOffsets *>
		tell [ 'ABC'.Label false
		     , 'ABC'.PushB False ] *>
		growStack {zero & bsize=1} *>
		tell [ 'ABC'.Label end ]
	gen (BuiltinApp2 e1 Cons e2) =
		genToAStack e2 *>
		genToAStack e1 *>
		tell [ 'ABC'.Raw "\tbuildh\t_Cons\t2" ] *>
		shrinkStack {zero & asize=1}
	gen (BuiltinApp2 e1 op e2) =
		mapM gen [e2,e1] *>
		gen op
	gen (Tuple i es) =
		comment "Building tuple" *>
		mapM genToAStack (reverse es) *>
		tell [ 'ABC'.Raw $ "\tbuildh\t_Tuple\t" <+ i ] *>
		shrinkStack {zero & asize=i-1}
	gen (List _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
	gen (List t [e:es]) =
		getType e >>= \te ->
		gen (BuiltinApp2 e Cons (List (t <|> pure te) es))
	gen e=:(Field f e`)
	| isTuple =
		getType e` >>= \t=:(TTuple arity tes) ->
		gen e` *>
		tell [ 'ABC'.ReplArgs arity arity
		     , 'ABC'.Pop_a (tupleEl - 1)
		     , 'ABC'.Update_a 0 (arity - tupleEl)
		     , 'ABC'.Pop_a (arity - tupleEl) ] *>
		if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *>
		case typeSize $ tes!!(tupleEl - 1) of
			{bsize=0} -> nop
			{btypes} -> mapM (flip toBStack 1) btypes *> nop
	| f == "hd" =
		fresh "iscons" >>= \iscons ->
		gen e` *>
		tell [ 'ABC'.EqDescArity "_Cons" 2 0
		     , 'ABC'.JmpTrue iscons ] *>
		tellAbort "hd of empty list" *>
		tell [ 'ABC'.Label iscons
		     , 'ABC'.ReplArgs 2 2
			 , 'ABC'.Update_a 0 1
			 , 'ABC'.Pop_a 1 ] *>
		getType e >>= \te ->
		case typeSize te of
			{bsize=0} -> nop
			{btypes} -> mapM (flip toBStack 1) btypes *> nop
	| f == "tl" =
		fresh "iscons" >>= \iscons ->
		gen e` *>
		tell [ 'ABC'.EqDescArity "_Cons" 2 0
		     , 'ABC'.JmpTrue iscons ] *>
		tellAbort "tl of empty list" *>
		tell [ 'ABC'.Label iscons
		     , 'ABC'.ReplArgs 2 2
			 , 'ABC'.Pop_a 1 ]
	| f == "nil" =
		gen e` *>
		tell [ 'ABC'.EqDescArity "_Nil" 0 0
		     , 'ABC'.Pop_a 1 ] *>
		growStack {asize=(-1), bsize=1, btypes=['ABC'.BT_Bool]}
	| otherwise =
		error $ C_UndefinedField f
	where
		f` = fromString f

		isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
		tupleEl = toInt $ toString $ tl f`

instance gen Op1
where
	gen op = tell [instr]
	where
		instr = case op of
			Neg -> 'ABC'.NegI
			Not -> 'ABC'.NotB
		type = case op of
			Neg -> 'ABC'.BT_Int
			Not -> 'ABC'.BT_Bool

instance gen Op2
where
	gen op = tell [instr] *> shrinkStack {zero & bsize=1}
	where
		instr = case op of
			Add    -> 'ABC'.AddI
			Sub    -> 'ABC'.SubI
			Mul    -> 'ABC'.MulI
			Div    -> 'ABC'.DivI
			Rem    -> 'ABC'.RemI
			Equals -> 'ABC'.EqI
		rettype = case op of
			Equals -> 'ABC'.BT_Bool
			_      -> 'ABC'.BT_Int

toBStack :: 'ABC'.BasicType Int -> Gen ()
toBStack t n =
	tell [push i \\ i <- [0..n-1]] *>
	tell ['ABC'.Pop_a n] *>
	growStack {zero & asize=0-n, bsize=n}
where
	push = case t of
		'ABC'.BT_Bool -> 'ABC'.PushB_a
		'ABC'.BT_Int  -> 'ABC'.PushI_a

BtoAStack :: 'ABC'.BasicType -> Gen ()
BtoAStack t =
	tell [ 'ABC'.Create
	     , fill 0 0
	     , 'ABC'.Pop_b 1
	     ] *>
	growStack {asize=1, bsize=(-1), btypes=[t]}
where
	fill = case t of
		'ABC'.BT_Bool -> 'ABC'.FillB_b
		'ABC'.BT_Int  -> 'ABC'.FillI_b

genToAStack :: Expression -> Gen ()
genToAStack (Literal (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
where toABCBool = toString o map toUpper o fromString o toString
genToAStack (Literal (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
genToAStack e = getType e >>= \t -> case typeSize t of
	{bsize=0} -> gen e
	{btypes}  -> gen e <* comment "To A-stack" <* mapM BtoAStack btypes <* comment "Done to A-stack"

comment :: String -> Gen ()
comment s = tell ['ABC'.Comment s]

toLabel :: a -> 'ABC'.Label | toString a
toLabel n = "__sil_" <+ n

toDAnnot :: TypeSize -> 'ABC'.Annotation
toDAnnot ts  = 'ABC'.DAnnot ts.asize ts.btypes

toDAnnot` :== toDAnnot o foldr (+~) zero

toOAnnot :: TypeSize -> 'ABC'.Annotation
toOAnnot ts  = 'ABC'.OAnnot ts.asize ts.btypes

toOAnnot` :== toOAnnot o foldr (+~) zero