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
|
implementation module ABC.Assembler
import StdEnv
import ABC.Machine
import ABC.Misc
assemble :: Assembler -> ([Instruction], [Desc])
assemble stms = (translate stms loc_counter syms, descTable stms syms)
where
loc_counter = 0
desc_counter = 0
syms = collect stms loc_counter desc_counter
:: SymType = LabSym | DescSym
instance == SymType
where
(==) LabSym LabSym = True
(==) DescSym DescSym = True
(==) _ _ = False
instance toString SymType
where
toString LabSym = "label"
toString DescSym = "descriptor"
:: SymTable :== [(Name, Int, SymType)]
collect :: Assembler Int Int -> SymTable
collect [] _ _ = []
collect [Label l :r] lc dc = [(l,lc,LabSym) :collect r lc dc]
collect [Descriptor dl rl _ _:r] lc dc = [(dl,dc,DescSym):collect r lc (dc+1)]
collect [_ :r] lc dc = collect r (lc+1) dc
lookup :: Label SymType SymTable -> Int
lookup l t [] = abortn ("label " <+ l <+ " not defined as " <+ t)
lookup l t [(name,n,type):r]
| l == name && t == type = n
| otherwise = lookup l t r
descTable :: Assembler SymTable -> [Desc]
descTable [] _ = []
descTable [Descriptor dl e a n:r] syms = [Desc ap_addr a n:descTable r syms]
where ap_addr = lookup e LabSym syms
descTable [_ :r] syms = descTable r syms
translate :: Assembler Int SymTable -> [Instruction]
translate [] _ _ = []
translate [Label _ :r] lc syms = translate r lc syms
translate [Descriptor _ _ _ _:r] lc syms = translate r lc syms
translate [stm :r] lc syms
= [trans stm lc syms:translate r (lc+1) syms]
where
trans :: Statement Int SymTable -> Instruction
trans (Br n) lc _ = jmp (lc+n+1)
trans (BrFalse n) lc _ = jmp_false (lc+n+1)
trans (BrTrue n) lc _ = jmp_true (lc+n+1)
trans (Dump s) _ _ = dump s
trans (AddArgs s n d) _ _ = add_args s n d
trans Create _ _ = create
trans (DelArgs s n d) _ _ = del_args s n d
trans (EqDesc dl s) _ syms = eq_desc daddr s
where daddr = (lookup dl DescSym syms)
trans (EqDescArity dl a s) _ syms = eq_desc_arity daddr a s
where daddr = (lookup dl DescSym syms)
trans EqB _ _ = eqB
trans (EqB_a b s) _ _ = eqB_a b s
trans (EqB_b b s) _ _ = eqB_b b s
trans EqI _ _ = eqI
trans (EqI_a i s) _ _ = eqI_a i s
trans (EqI_b i s) _ _ = eqI_b i s
trans (Fill l n e d) _ syms = fill daddr n eaddr d
where (daddr,eaddr) = (lookup l DescSym syms, lookup e LabSym syms)
trans (Fill_a s d) _ _ = fill_a s d
trans (FillB b d) _ _ = fillB b d
trans (FillB_b s d) _ _ = fillB_b s d
trans (FillI i d) _ _ = fillI i d
trans (FillI_b s d) _ _ = fillI_b s d
trans (GetDescArity s) _ _ = get_desc_arity s
trans (GetNodeArity s) _ _ = get_node_arity s
trans Halt _ _ = halt
trans (Jmp l) _ syms = jmp addr
where addr = lookup l LabSym syms
trans JmpEval _ _ = jmp_eval
trans (JmpFalse l) _ syms = jmp_false addr
where addr = lookup l LabSym syms
trans (JmpTrue l) _ syms = jmp_true addr
where addr = lookup l LabSym syms
trans (Jsr l) _ syms = jsr addr
where addr = lookup l LabSym syms
trans JsrEval _ _ = jsr_eval
trans NoOp _ _ = no_op
trans (Pop_a n) _ _ = pop_a n
trans (Pop_b n) _ _ = pop_b n
trans (Print s) _ _ = print s
trans (PrintSymbol s) _ _ = print_symbol s
trans (Push_a s) _ _ = push_a s
trans (PushAPEntry s) _ _ = push_ap_entry s
trans (PushArg s a n) _ _ = push_arg s a n
trans (PushArg_b s) _ _ = push_arg_b s
trans (PushArgs s a n) _ _ = push_args s a n
trans (PushArgs_b s) _ _ = push_args_b s
trans (Push_b i) _ _ = push_b i
trans (PushB b) _ _ = pushB b
trans (PushB_a s) _ _ = pushB_a s
trans (PushI i) _ _ = pushI i
trans (PushI_a s) _ _ = pushI_a s
trans (ReplArgs a n) _ _ = repl_args a n
trans ReplArgs_b _ _ = repl_args_b
trans Rtn _ _ = rtn
trans (SetEntry l d) _ syms = set_entry addr d
where addr = lookup l LabSym syms
trans (Update_a s d) _ _ = update_a s d
trans (Update_b s d) _ _ = update_b s d
trans AddI _ _ = addI
trans DecI _ _ = decI
trans GtI _ _ = gtI
trans IncI _ _ = incI
trans LtI _ _ = ltI
trans MulI _ _ = mulI
trans SubI _ _ = subI
|
