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
131
132
133
134
135
136
|
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 = combineGlobals
[ builtin
, gatherGlobals ns defs
]
builtin =
{ constructors = 'Data.Map'.fromList
[ ({ns="", id="INT"}, ConstructorDef "INT" [])
]
, functions = 'Data.Map'.newMap
}
combineGlobals :: ![Globals] -> Globals
combineGlobals sets =
{ constructors = 'Data.Map'.unions [g.constructors \\ g <- sets]
, functions = 'Data.Map'.unions [g.functions \\ g <- sets]
}
gatherGlobals :: !Namespace ![Definition] -> Globals
gatherGlobals ns defs =
{ constructors = 'Data.Map'.fromList
[ ({ns=ns, id=id}, cons)
\\ DataDef _ _ conses <- defs
, cons=:(ConstructorDef id _) <- conses
]
, functions = 'Data.Map'.fromList
[ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))})
\\ FunDef id args ret _ <- defs
]
}
lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions
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"
// TODO: Ideally we would use the following here:
//, Align 1
//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
//, RawByte (length args) // arity
// But since SPIM does not allow .byte in the text section, we use:
, Align 2
, RawWord
(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
(length args << 8)) // arity
// instead... (end modification)
, 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 1
, Label (constructorLabel ns id)
, RawByte (length args) // pointer arity
, RawByte 0 // basic value arity
, RawByte 0 // number of arguments still to be curried in
]
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 ns globals locals (Symbol id) = // TODO include locals
case lookupFunction ns id globals of
?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
?Just info ->
case info.arity of
0 ->
buildThunk (functionLabel ns NodeEntry id) 0
_ ->
abort "symbol with arity > 0\n" // TODO implement
simulator _ _ _ _ = // TODO
pushBasicValue (BVInt 0) >>|
buildCons (constructorLabel "" "INT") 1
// | Symbol !SymbolIdent
// | Constructor !ConstructorIdent
// | Case !Expression ![CaseAlternative]
// | ExpApp !Expression !Expression
|
