blob: 4313c0e605d1138a40f1fa9956049aa12aff1641 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
implementation module Sil.Compile
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
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 start () zero of
Error e -> Error e
Ok (_,p) -> Ok p
where
start = mapM_ gen prog.p_funs
:: Address
= LabelAddr String
| StackAddr Int
:: CompileState =
{ labels :: ['ABC'.Label]
, addresses :: 'M'.Map Name Address
}
instance zero CompileState
where
zero =
{ labels = ["_l" <+ i \\ i <- [0..]]
, addresses = 'M'.newMap
}
labels :: CompileState -> ['ABC'.Label]
labels cs = cs.labels
addresses :: CompileState -> 'M'.Map Name Address
addresses cs = cs.addresses
:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
fresh :: Gen 'ABC'.Label
fresh = gets labels
>>= \labs -> modify (\cs -> {cs & labels=tl labs})
*> pure (hd labs)
reserveVar :: Int Name -> Gen Int
reserveVar i n = modify (\cs -> {cs & addresses='M'.put n (StackAddr i) cs.addresses}) *> pure (i + 1)
class gen a :: a -> Gen ()
instance gen Function
where
gen f = tell ['ABC'.Label f.f_name] *> gen f.f_code
instance gen CodeBlock
where
gen cb = foldM reserveVar 1 [i.init_name \\ i <- cb.cb_init] *>
mapM_ gen cb.cb_init *>
mapM_ gen cb.cb_content
instance gen Initialisation
where
gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]
instance gen Statement
where
gen (Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just (StackAddr i) -> comment "Declaration" *> gen app *> tell ['ABC'.Fill_a 0 i]
Just (LabelAddr _) -> liftT $ Error VariableLabel
_ -> liftT $ Error $ UndefinedName n
gen (Application app) = comment "Application" *> gen app
gen (Return (Just app)) = comment "Return" *> gen app *> tell ['ABC'.Rtn]
gen (Return Nothing) = comment "Return" *> tell ['ABC'.Rtn]
instance gen Application
where
gen (Name n) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just (StackAddr i) -> comment "Retrieve name" *> tell ['ABC'.Push_a i]
Just (LabelAddr _) -> liftT $ Error VariableLabel
_ -> liftT $ Error $ UndefinedName n
gen (Literal (BLit b)) = comment "Literal" *> tell ['ABC'.Create, 'ABC'.FillB b 0]
gen (Literal (ILit i)) = comment "Literal" *> tell ['ABC'.Create, 'ABC'.FillI i 0]
gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just (LabelAddr l) ->
comment "Retrieve arguments" *> mapM gen args *>
comment "Apply function" *> tell ['ABC'.Jsr l]
Just (StackAddr _) -> liftT $ Error FunctionOnStack
_ -> liftT $ Error $ UndefinedName n
comment :: String -> Gen ()
comment s = tell ['ABC'.Comment s]
|
