path: root/Sil/Compile.icl

implementation module Sil.Compile

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.Syntax
import Sil.Types
import Sil.Util.Printer

instance toString CompileError
where
	toString (UndefinedName n)         = "Undefined name '" <+ n <+ "'."
	toString VariableLabel             = "Variable stored at label."
	toString FunctionOnStack           = "Function stored on the stack."
	toString (TypeError err e)         = "Type error in '" <+ e <+ "': " <+ err
	toString (CouldNotDeduceType e)    = "Could not deduce type of '" <+ e <+ "'."
	toString (TypeMisMatch t e)        = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
	toString (BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value."
	toString UnknownError              = "Unknown error."

error :: CompileError -> RWST r w s (MaybeError CompileError) 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 CompileError '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
	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]
	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]
	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

:: 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 CompileError) 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 $ 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}

checkType :: Type Expression -> Gen ()
checkType t e = getTypeResolver >>= \tr -> case type tr e of
	Nothing          -> error $ CouldNotDeduceType e
	Just (Error err) -> error $ TypeError err e
	Just (Ok t`)     -> if (t == t`) nop (error $ TypeMisMatch t e)

checkTypeName :: Name Expression -> Gen Type
checkTypeName n e = getTypeResolver >>= \tr -> case type tr n of
	Nothing          -> error $ CouldNotDeduceType $ Name n
	Just (Error err) -> error $ TypeError err $ Name n
	Just (Ok t`)     -> checkType t` e $> t`

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 TypeError 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) *> growStack {retSize & bsize=0} *>
		mapM_ reserveVar [(a.arg_name, a.arg_type) \\ a <- f.f_args] *>
		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 TypeError 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'.Create
				     , 'ABC'.Raw "\tfillh e__predef_d_Unit 0 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 TypeError 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 $ BasicInitWithoutValue init.init_name
			Just 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 $ TypeError err e
			Nothing          -> error $ CouldNotDeduceType e
	gen (Return (Just e)) =
		comment "Return" *>
		gen e *>
		gets returnType >>= \rettype ->
		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 -> liftT $ Error 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)
			_ -> liftT $ Error $ UndefinedName n
	gen (BuiltinApp op arg) = genToBStack arg *> gen op
	gen (BuiltinApp2 e1 LogOr e2) =
		checkType TBool e1 *>
		checkType TBool e2 *>
		fresh "or_true" >>= \true ->
		fresh "or_end" >>= \end ->
		storeStackOffsets *>
		genToBStack e1 *>
		tell [ 'ABC'.JmpTrue true ] *>
		genToBStack 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 *>
		genToBStack e1 *>
		tell [ 'ABC'.JmpFalse false ] *>
		genToBStack e2 *>
		tell [ 'ABC'.Jmp end ] *>
		restoreStackOffsets *>
		tell [ 'ABC'.Label false
		     , 'ABC'.PushB False ] *>
		growStack {zero & bsize=1} *>
		tell [ 'ABC'.Label end ]
	gen (BuiltinApp2 e1 op e2) = mapM genToBStack [e2,e1] *> gen op

genToBStack :: Expression -> Gen ()
genToBStack (Name n) = findVar n >>= getLoc
where
	getLoc :: Address -> Gen ()
	getLoc (AAddr i) = tell ['ABC'.PushI_a $ i] *> growStack {zero & bsize=1}
	getLoc (BAddr i) = tell ['ABC'.Push_b  $ i] *> growStack {zero & bsize=1}
genToBStack e = gen e

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
			LogOr  -> 'ABC'.AddI // TODO remove hack
			LogAnd -> 'ABC'.MulI // TODO remove hack
		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

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