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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
implementation module Snug.Compile
import StdEnv
import Data.List
import qualified Data.Map
from Data.Map import :: Map
import Text
import MIPS.MIPS32
import Snug.Syntax
:: Locals :== Map SymbolIdent MemoryLocation
:: MemoryLocation
= InRegister !Register
| Indirect !Register !Offset
:: EntryPoint
= NodeEntry
BackPrintPtr :== S 0
FrontPrintPtr :== S 1
BackEvalPtr :== S 2
FrontEvalPtr :== S 3
HeapPtr :== GP
instance == (Namespaced id) | == id
where
(==) x y = x.id == y.id && x.ns == y.ns
instance < (Namespaced id) | < id
where
(<) x y
| x.id < y.id = True
| x.id > y.id = False
| otherwise = x.ns < y.ns
compile :: !Namespace ![Definition] -> [Line]
compile ns defs =
concatMap (compileDefinition ns globals) defs
where
globals =
{ constructors = 'Data.Map'.fromList
[ ({ns="", id="INT"}, ConstructorDef "INT" [])
]
, functions = 'Data.Map'.newMap
}
compileDefinition :: !Namespace !Globals !Definition -> [Line]
compileDefinition _ _ (TypeDef _ _) =
[]
compileDefinition ns globals (DataDef _ _ constructors) =
[ StartSection "data"
: concatMap (compileConstructor ns globals) constructors
]
compileDefinition ns globals (FunDef id args ret expr) =
[ StartSection "text"
, Align 3 // to have 3 bits unused in addresses
, RawWord (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
, RawWord (length args) // arity
, Label (functionLabel ns NodeEntry id)
: map Instr (compileExpr ns globals locals expr)
]
where
locals = 'Data.Map'.fromList
[ (id, Indirect FrontEvalPtr (offset*4))
\\ (id,_) <- args
& offset <- [1..]
]
compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
compileConstructor ns _ (ConstructorDef id args) =
[ Align 3 // to have 3 bits unused in addresses
, Label (constructorLabel ns id)
, RawWord (length args) // arity
, RawWord (size id) // length name
, RawAscii id // name
]
compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
compileExpr _ _ _ (BasicValue bv) =
// Build new node
[ LoadAddress (T 0) (Address 2 (constructorLabel "" (label bv)))
, StoreWord (T 0) 0 HeapPtr
] ++
loadImmediate bv ++
[ StoreWord (T 0) 4 HeapPtr
// Overwrite old node with indirection
, LoadAddress (T 0) (Address 0 (functionLabel "" NodeEntry "indir"))
, StoreWord (T 0) 0 FrontEvalPtr
, StoreWord HeapPtr 4 FrontEvalPtr
// Update front and heap pointers; return
, Move FrontEvalPtr HeapPtr
, Jump NoLink (Direct (Address 0 "eval"))
, AddImmediate Signed GP GP (Immediate 8)
]
where
label (BVInt _) = "INT"
label (BVChar _) = "CHAR"
loadImmediate (BVInt i)
| 0 <= i && i < 0x10000 =
[ OrImmediate (T 0) R0 (Immediate i)
]
| 0 > i && i >= -0x8000 =
[ AddImmediate Signed (T 0) R0 (Immediate i)
]
| otherwise =
[ LoadUpperImmediate (T 0) (Immediate (i >> 16))
, OrImmediate (T 0) (T 0) (Immediate (i bitand 0xffff))
]
compileExpr _ _ _ _ = [Nop]// TODO
// | Symbol !SymbolIdent
// | Constructor !ConstructorIdent
// | Case !Expression ![CaseAlternative]
// | ExpApp !Expression !Expression
constructorLabel :: !Namespace !ConstructorIdent -> Label
constructorLabel "" id = "_c" +++ id // for built-in constructors
constructorLabel ns id = concat4 "__" ns "_c" id // TODO escaping
functionLabel :: !Namespace !EntryPoint !ConstructorIdent -> Label
functionLabel ns entry_point id // TODO escaping
| size ns == 0
= {#'_',e} +++ id
= concat4 "__" ns {#'_',e} id
where
e = case entry_point of
NodeEntry -> 'n'
|
