path: root/Sil/Compile.icl

implementation module Sil.Compile

import StdEnum
from StdFunc import 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 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.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 UnknownError      = "Unknown error."

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]
	}

instance zero CompileState
where
	zero =
		{ labels        = ["_l" <+ i \\ i <- [0..]]
		, addresses     = 'M'.newMap
		, symbols       = 'M'.newMap
		, returns       = []
		, stackoffset   = 0
		, storedoffsets = []
		}

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

newReturn :: 'ABC'.Assembler CompileState -> CompileState
newReturn ret cs = {cs & returns=[ret:cs.returns]}

addToReturn :: 'ABC'.Assembler CompileState -> CompileState
addToReturn ret cs=:{returns=[r:rs]} = {cs & returns=[ret ++ r:rs]}

removeFromReturn :: Int CompileState -> CompileState
removeFromReturn i cs=:{returns=[r:rs]} = {cs & returns=[drop i r:rs]}

popReturn :: CompileState -> CompileState
popReturn cs = {cs & returns=tl cs.returns}

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

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

storeStackOffset :: CompileState -> CompileState
storeStackOffset cs = {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]}

restoreStackOffset :: CompileState -> CompileState
restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos}
where [so:sos] = cs.storedoffsets

:: 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})
	*> pure (n <+ hd labs)

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

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"
		     ] *>
		mapM_ addFunction p.p_funs *>
		mapM_ gen p.p_funs

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] *>
		modify (newReturn cleanup`) *>
		gen f.f_code *>
		cleanup *>
		modify (\cs -> {cs & stackoffset=0}) *>
		tell ['ABC'.Rtn] *>
		modify 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

instance gen CodeBlock
where
	gen cb =
		modify storeStackOffset *>
		foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
		mapM_ gen cb.cb_init *>
		modify (addToReturn cleanup`) *>
		mapM_ gen cb.cb_content *>
		tell cleanup` *>
		modify (removeFromReturn $ length cleanup`) *>
		modify restoreStackOffset
	where
		cleanup` = case cb.cb_init of
			[] -> []
			_  -> [ 'ABC'.Pop_a locals ]
		locals = length cb.cb_init

instance gen Initialisation
where
	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1

instance gen Statement
where
	gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just i -> comment (toString st) *> gen app *>
		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> shrinkStack 1
		_      -> liftT $ Error $ UndefinedName n
	gen (Application e)   = comment "Application" *> gen e *> tell ['ABC'.Pop_a 1] *> shrinkStack 1
	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) =
			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) =
		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 1 []
				     ] *>
				shrinkStack (fs.fs_arity - 1)
			_ -> 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]