path: root/Sil/Compile.icl

implementation module Sil.Compile

import StdEnum
from StdFunc import const, flip, o
import StdList
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 qualified Data.Map as M
import Data.Maybe
import Data.Monoid
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 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 (gen prog) () zero of
	Error e  -> Error e
	Ok (_,p) -> Ok p

:: Address :== Int

:: FunctionSymbol =
	{ fs_arity   :: Int
	, fs_rettype :: Type
	}

:: CompileState =
	{ labels        :: ['ABC'.Label]
	, addresses     :: 'M'.Map Name Address
	, symbols       :: 'M'.Map Name FunctionSymbol
	, returns       :: ['ABC'.Assembler]
	, stackoffset   :: Int
	, storedoffsets :: [Int]
	, typeresolvers :: [TypeResolver]
	}

instance zero CompileState
where
	zero =
		{ labels        = ["_l" <+ i \\ i <- [0..]]
		, addresses     = 'M'.newMap
		, symbols       = 'M'.newMap
		, returns       = []
		, stackoffset   = 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

stackoffset :: CompileState -> Int
stackoffset cs = cs.stackoffset

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})
	$> n <+ hd labs

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

restoreStackOffset :: Gen ()
restoreStackOffset = modify \cs=:{storedoffsets=[so:sos]} -> {cs & stackoffset=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}

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 :: Int Name -> Gen Int
reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) $> (i+1)

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_rettype = f.f_type
	     }

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

growStack :: Int -> Gen ()
growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})

shrinkStack :: (Int -> Gen ())
shrinkStack = growStack o ((-) 0)

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 ()
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

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 "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 (const Nothing) f

instance gen Function
where
	gen f =
		tell [ 'ABC'.Annotation $ 'ABC'.OAnnot args []
		     , 'ABC'.Label f.f_name
		     ] *>
		foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
		newReturn cleanup` *>
		pushTypeResolver typeresolver *>
		gen f.f_code *>
		popTypeResolver *>
		cleanup *>
		modify (\cs -> {cs & stackoffset=0}) *>
		tell ['ABC'.Rtn] *>
		popReturn
	where
		cleanup` = case f.f_args of
			[] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot retSize []
			      ]
			_  -> [ 'ABC'.Comment "Cleanup"] ++
			      [ 'ABC'.Update_a i (args+i) \\ i <- [0..retSize-1] ] ++
			      [ 'ABC'.Pop_a args
			      , 'ABC'.Annotation $ 'ABC'.DAnnot retSize []
			      ]
		retSize = typeSize f.f_type
		args = length f.f_args
		locals = length f.f_code.cb_init

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

instance gen CodeBlock
where
	gen cb =
		storeStackOffset *>
		foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
		mapM_ gen cb.cb_init *>
		addToReturn cleanup` *>
		pushTypeResolver typeresolver *>
		mapM_ gen cb.cb_content *>
		popTypeResolver *>
		tell cleanup` *>
		removeFromReturn (length cleanup`) *>
		restoreStackOffset
	where
		cleanup` = case cb.cb_init of
			[] -> []
			_  -> [ 'ABC'.Pop_a locals ]
		locals = length 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 = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1

instance gen Statement
where
	gen st=:(Declaration n e) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just i -> checkTypeName n e *>
		          comment (toString st) *>
		          gen e *>
		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> // TODO should depend on size of return type
		          shrinkStack 1
		_      -> liftT $ Error $ UndefinedName n
	gen (Application e) =
		comment "Application" *>
		gen e *>
		getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of
			Just (Ok 0)      -> nop
			Just (Ok sz)     -> tell ['ABC'.Pop_a sz] *> shrinkStack sz
			Just (Error err) -> error $ TypeError err e
			Nothing          -> error $ CouldNotDeduceType e
	gen (Return (Just e)) =
		comment "Return" *>
		gen e *>
		cleanup *>
		tell ['ABC'.Rtn]
	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 ->
			gen cond *>
			toBStack 'ABC'.BT_Bool 1 *>
			tell [ 'ABC'.JmpFalse else ] *>
			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 *>
		toBStack 'ABC'.BT_Bool 1 *>
		tell [ 'ABC'.JmpFalse end ] *>
		gen do *>
		tell [ 'ABC'.Jmp loop
		     , 'ABC'.Label end ]

instance gen Expression
where
	gen (Name n) =
		gets stackoffset >>= \so ->
		gets addresses >>= \addrs ->
		case 'M'.get n addrs of
			Just i -> tell ['ABC'.Push_a $ i + so] *> growStack 1
			_      -> liftT $ Error $ UndefinedName n
	gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0] *> growStack 1
	gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0] *> growStack 1
	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 $ 'ABC'.DAnnot fs.fs_arity []
				     , 'ABC'.Jsr n
				     , 'ABC'.Annotation $ 'ABC'.OAnnot (typeSize fs.fs_rettype) []
				     ] *>
				shrinkStack (fs.fs_arity - typeSize fs.fs_rettype)
			_ -> liftT $ Error $ UndefinedName n
	gen (BuiltinApp op arg) = gen arg *> gen op
	gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op

instance gen Op1
where
	gen op =
		toBStack type 1 *>
		tell [instr] *>
		BtoAStack type
	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 =
		toBStack 'ABC'.BT_Int 2 *>
		tell [instr] *>
		BtoAStack rettype
	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 (if (n <> 0) ['ABC'.Pop_a n] []) *>
	shrinkStack 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 1
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]