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
|
implementation module Snug.Compile
import StdEnv
import Control.Monad
import Data.Func
import Data.List
import qualified Data.Map
from Data.Map import :: Map
import MIPS.MIPS32
import Snug.Compile.ABI
import Snug.Compile.Simulate
import Snug.Syntax
:: Locals :== Map SymbolIdent MemoryLocation
:: MemoryLocation
= InRegister !Register
| Indirect !Register !Offset
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 ns globals locals expr = simulate $
simulator ns globals locals expr >>|
indirectAndEval
simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
simulator _ _ _ (BasicValue bv) =
pushBasicValue bv >>|
buildCons (constructorLabel "" (label bv)) 1
where
label (BVInt _) = "INT"
label (BVChar _) = "CHAR"
simulator _ _ _ _ = // TODO
pushBasicValue (BVInt 0) >>|
buildCons (constructorLabel "" "INT") 1
// | Symbol !SymbolIdent
// | Constructor !ConstructorIdent
// | Case !Expression ![CaseAlternative]
// | ExpApp !Expression !Expression
|
