3 (* Data Segment
- initialized data
segment (constants
) *)
4 structure DataSegment
: sig
5 val reset
: unit
-> unit (* reset symbol
and constant tables between code generations
*)
6 val add
: Sexpr
-> string (* register a new constant
*)
7 val emit
: unit
-> string (* emit code for all constants
*)
8 val symbols
: (string*string) list (* fetch all constant symbols
*)
10 (* new_name
- generate unique names
*)
13 "sc_undef", "sc_void", "sc_nil", "sc_false_data", "sc_true_data"]
14 val (names
:string list ref
) = ref initial_names
17 fun is_new name
= not (List.exists (fn n
=> n
=name
) (!names
)) (* allocate new distinct name
*)
18 fun add name
= names
:= name
:: !names (* add names to the table
of existing ones
*)
20 (* if the name is not
in the table
, register
and return it
,
21 otherwise
, add an increasing number to it until a distinct name is found
*)
27 let fun subname name i
=
28 let val name
' = name ^
(Int.toString i
)
29 in if is_new name
' then
33 subname
name (i
+ 1) end
37 (* list
of constants
*)
38 val consts
= ref
[] : (string*Sexpr
) list ref
;
40 (* convert the collected consts to global variables
in C
*)
42 (* table
of symbol names
and representations
;
44 - maintain a single representation for all occurences
of a symbol
45 - register symbols
in run
-time symbol table for symbol
->string and string->symbol
*)
46 val (symbols
: (string*string) list ref
) = ref
[]
48 (* return existing name for singletons
, otherwise generate a new one
;
49 the singletons are hardcoded once
and forever
, so that they are eq? comparable
*)
54 |
Bool false => "sc_false"
55 |
Bool true => "sc_true"
56 | Symbol s
=> (* symbols must be eq? comparable
*)
57 (case List.find (fn sc
=> (#
1 sc
)=s
) (!symbols
)
59 | NONE
=> let val name
= new_name ("sc_symbol")
60 in symbols
:= (s
, name
) :: (!symbols
);
63 | _
=> (* anything
else is just new constant every time
*)
65 of (Pair _
) => "sc_pair"
66 |
(Vector _
) => "sc_vector"
67 |
(String _
) => "sc_string"
68 |
(Number _
) => "sc_number"
69 |
(Char _
) => "sc_char"))
71 (* generate code for a single constant
:
74 constant definition
- a value
of SchemeObject
type *)
76 fun const_code (name
, scheme_type
, data_name
, data_variant
, data_value
) =
77 "SchemeObjectData " ^ data_name ^
" = {" ^
"." ^ data_variant ^
" = {" ^ data_value ^
"}};\n" ^
78 "SchemeObject " ^ name ^
" = {" ^ scheme_type ^
", &" ^ data_name ^
"};\n"
80 (* symbol representation is written once for every symbol
*)
82 val (written_symbols
: string list ref
) = ref
[]
84 fun emit_const (name
, value
) =
86 of Pair (a
,d
) => emit_pair (name
, a
, d
)
87 |
Vector es
=> emit_vector (name
, es
)
88 | Symbol s
=> (* the same symbol may appear several times
, but must be emitted only once
*)
89 if (List.exists (fn n
=>n
=name
) (!written_symbols
))
91 else ( written_symbols
:= name
:: (!written_symbols
)
92 ; emit_symbol (name
, s
) )
93 |
String s
=> emit_string (name
, s
)
94 | Number i
=> emit_number (name
, i
)
95 |
Char c
=> emit_char (name
, c
)
96 | _
=> "" (* singletons
*)
98 and emit_pair (name
, a
, d
) =
100 val a_name
= const_name (a
)
101 val d_name
= const_name (d
)
102 val data_name
= new_name (name ^
"_data")
103 (* recusrively define car
and cdr
*)
104 val a_code
= emit_const (a_name
, a
)
105 val d_code
= emit_const (d_name
, d
)
106 in (a_code ^ d_code ^
(const_code (name
, "SCHEME_PAIR", data_name
,
107 "spd", "&" ^ a_name ^
", &" ^ d_name
))) end
109 (* generates names
and statements for a list
of constants
.
110 returns a list
of names
and a (matching
) list
of statements
*)
111 and sexprs_to_stmts
[] names stmts
= (names
,stmts
)
112 |
sexprs_to_stmts (em
:: rest
) names stmts
=
113 let val name
= const_name
em (* generate name
*)
114 val stmt
= emit_const (name
,em
) (* generate code
*)
116 sexprs_to_stmts
rest (names @
[name
]) (stmts @
[stmt
])
119 and emit_vector (name
, es
) =
121 (* generate names
and statements for the vector elements
*)
122 val (em_names
,em_stmts
) = sexprs_to_stmts es
[] []
123 (* generate name
,statement for the array that holds the elements
*)
124 val arr_name
= new_name (name^
"_arr")
125 val arr_stmt
= "SchemeObject* "^arr_name^
"[] = {&"^
126 (String.concatWith
", &" em_names
)^
"};\n"
127 val data_name
= new_name (name^
"_data")
129 (String.concat em_stmts
)^
131 const_code (name
, "SCHEME_VECTOR", data_name
, "svd",
132 (Int.toString (List.length es
))^
", "^arr_name
)
135 and emit_symbol (name
, s
) =
136 let val data_name
= new_name (name ^
"_data")
137 val syment_name
= new_name (name ^
"_syment")
138 in ("SymbolEntry "^syment_name^
" = {\""^
(String.toCString s
)^
"\",0,NULL};\n"^
139 const_code (name
, "SCHEME_SYMBOL", data_name
, "smd",
143 and emit_string (name
, s
) =
144 let val data_name
= new_name (name ^
"_data")
145 in (const_code (name
, "SCHEME_STRING", data_name
, "ssd",
146 (Int.toString (String.size s
))^
", \""^
(String.toCString s
)^
"\""))
149 and emit_number (name
, i
) =
150 let val data_name
= new_name (name ^
"_data")
151 in (const_code (name
, "SCHEME_INT", data_name
, "sid",
152 "(int)" ^
(if i
<0 then "-"^
(Int.toString (~i
))
153 else (Int.toString i
))))
156 and emit_char (name
, c
) =
157 let val data_name
= new_name (name ^
"_data")
158 in (const_code (name
, "SCHEME_CHAR", data_name
,
159 "scd", "(char)" ^
(Int.toString (Char.ord c
)))) end
164 ; written_symbols
:= [] )
167 let val name
= const_name x
168 in consts
:= (name
, x
) :: (!consts
) (* repeated symbols are detected
in emit_const
*)
172 "SchemeObject sc_undef = {-1, NULL};\n" ^
173 "SchemeObject sc_void = {SCHEME_VOID, NULL};\n" ^
174 "SchemeObject sc_nil = {SCHEME_NIL, NULL};\n" ^
175 "SchemeObjectData sc_false_data = {.sbd = {0}};\n" ^
176 "SchemeObject sc_false = {SCHEME_BOOL, &sc_false_data};\n" ^
177 "SchemeObjectData sc_true_data = {.sbd = {1}};\n" ^
178 "SchemeObject sc_true = {SCHEME_BOOL, &sc_true_data};\n" ^
179 String.concat (map
emit_const (List.rev (!consts
)))
181 (* freeze the symbols
*)
182 val symbols
= !symbols
184 end; (* DataSegment
*)
186 structure ErrType
= struct
189 | ArgsCount
of string * int
192 | UndefinedSymbol
of string;
194 fun toString None
= "\"\""
195 |
toString (ArgsCount (proc
,formals
)) = "MSG_ERR_ARGCOUNT(\""^
196 (String.toCString proc
)^
"\","^
197 (intToCString formals
)^
")"
198 | toString AppNonProc
= "MSG_ERR_APPNONPROC"
199 | toString NotAPair
= "MSG_ERR_NOTPAIR"
200 |
toString (UndefinedSymbol name
) = "\"Symbol "^
(String.toCString name
)^
" not defined\""
203 structure CodeSegment (* : sig
206 val reset
: unit
-> unit
;
207 val add
: StatementType
-> unit
;
208 val emit
: unit
-> string;
210 datatype StatementType
=
214 | Assertion
of string * ErrType
.Type
215 | Error
of ErrType
.Type
216 | ErrorIf
of string * ErrType
.Type
218 | BranchIf
of string * string
219 | Set
of string * string
223 | Statement
of string;
225 fun statementToString (Statement stmt
) = "\t"^stmt^
";"
226 |
statementToString (Set (n
,v
)) = "\t"^n^
" = "^v^
";"
227 |
statementToString (Branch l
) = "\tgoto "^l^
";"
228 |
statementToString (BranchIf (c
,l
)) = "\tif ("^c^
") goto "^l^
";"
229 |
statementToString (Comment s
) = "\t/* "^s^
" */"
230 |
statementToString (Debug s
) = "" (* "\tfprintf(stderr,\"DEBUG: "^
(String.toCString s
)^
"\\n\");" *)
231 |
statementToString (Label s
) = s^
":"
232 |
statementToString (Assertion (p
,e
)) = "\tASSERT_ALWAYS("^p^
","^
(ErrType
.toString e
)^
");"
233 |
statementToString (Error e
) = "\tfprintf(stderr,"^
(ErrType
.toString e
)^
"); exit(-1);"
234 |
statementToString (ErrorIf (p
,e
)) = "\tif ("^p^
") {fprintf(stderr,"^
(ErrType
.toString e
)^
"); fprintf(stderr,\"%s %d\\n\",__FILE__,__LINE__); exit(-1);}"
235 |
statementToString (Push s
) = "\tpush("^s^
");"
236 |
statementToString (Pop s
) = "\t"^s^
" = pop();"
237 | statementToString Return
= "\tRETURN();"
240 val statements
= ref
[] : StatementType list ref
;
245 fun add stmt
= statements
:= !statements @
[stmt
];
249 (String.concatWith
"\n" (List.map
statementToString (!statements
)))^
252 end; (* CodeSegment
*)
254 structure Program
: sig
255 val reset
: unit
-> unit
;
256 val gen
: Expr
-> int -> unit
;
257 val emit
: int * int -> string;
260 fun makeLabeler prefix
=
264 fn () => (number
:= !number
+ 1
265 ;prefix^
(Int.toString (!number
)))
268 val makeLabelElse
= makeLabeler
"else";
269 val makeLabelEndif
= makeLabeler
"endIf";
270 val makeLabelEndOr
= makeLabeler
"endOr";
271 val makeLabelSkipBody
= makeLabeler
"skipBody";
272 val makeLabelBody
= makeLabeler
"body";
273 val makeLabelRet
= makeLabeler
"ret";
274 val makeLabelApp
= makeLabeler
"app";
276 val CSadd
= CodeSegment
.add
;
279 (CSadd (CodeSegment
.Comment
"<push an initial activation frame>")
280 ;CSadd (CodeSegment
.Comment
"no arguments")
281 ;CSadd (CodeSegment
.Push
"0")
282 ;CSadd (CodeSegment
.Comment
"no enviroment")
283 ;CSadd (CodeSegment
.Push
"(int)NULL")
284 ;CSadd (CodeSegment
.Comment
"no return address (yet. will be set later)")
285 ;CSadd (CodeSegment
.Push
"(int)NULL")
286 ;CSadd (CodeSegment
.Push
"fp")
287 ;CSadd (CodeSegment
.Set ("fp","sp"))
288 ;CSadd (CodeSegment
.Comment
"</push an initial activation frame>")
292 (CSadd (CodeSegment
.Comment
"<pop the initial activation frame>")
293 ;CSadd (CodeSegment
.Pop
"fp")
294 ;CSadd (CodeSegment
.Comment
"</pop the initial activation frame>")
298 (DataSegment
.reset ()
299 ;CodeSegment
.reset ()
303 fun maprtl f l
= map
f (List.rev l
);
305 fun genDebug (App (VarFree name
,_
)) = CSadd (CodeSegment
.Debug ("Applying free-var "^name
))
306 |
genDebug (AppTP (VarFree name
,_
)) = CSadd (CodeSegment
.Debug ("Applying free-var "^name
))
307 |
genDebug (App (VarParam (name
,_
),_
)) = CSadd (CodeSegment
.Debug ("Applying param "^name
))
308 |
genDebug (AppTP (VarParam (name
,_
),_
)) = CSadd (CodeSegment
.Debug ("Applying param "^name
))
309 |
genDebug (App (VarBound (name
,_
,_
),_
)) = CSadd (CodeSegment
.Debug ("Applying bound-var "^name
))
310 |
genDebug (AppTP (VarBound (name
,_
,_
),_
)) = CSadd (CodeSegment
.Debug ("Applying bound-var "^name
))
314 (* Generate code for a given expression
315 THE INVARIANT
: r_res contains the value
of the
316 expression after execution
318 fun genExpr (Const se
) absDepth
=
320 val lblConst
= DataSegment
.add se
322 CSadd (CodeSegment
.Set ("r_res","(int)&"^lblConst
))
324 |
genExpr (Var _
) absDepth
= raise Match (* shouldn
't be here
*)
325 |
genExpr (VarFree name
) absDepth
=
327 val lblElse
= makeLabelElse ()
328 val lblEndif
= makeLabelEndif ()
329 in (* probe for symbol
in runtime data
-structure *)
330 (CSadd (CodeSegment
.Set ("r_res","(int)probeSymbolDefined(\""^name^
"\",topLevel)"))
331 ;CSadd (CodeSegment
.BranchIf ("r_res==0",lblElse
))
332 ;CSadd (CodeSegment
.BranchIf ("! ((SymbolEntry*)r_res)->isDefined",lblElse
))
333 ;CSadd (CodeSegment
.Set ("r_res","(int)((SymbolEntry*)r_res)->sob"))
334 ;CSadd (CodeSegment
.Branch lblEndif
)
335 ;CSadd (CodeSegment
.Label lblElse
)
336 ;CSadd (CodeSegment
.Error (ErrType
.UndefinedSymbol name
))
337 ;CSadd (CodeSegment
.Label lblEndif
)
340 |
genExpr (VarParam (name
,ndx
)) absDepth
=
341 (CSadd (CodeSegment
.Assertion ("("^
(intToCString ndx
)^
">=0) & ("^
(intToCString ndx
)^
"<ST_ARG_COUNT())",ErrType
.None
))
342 ;CSadd (CodeSegment
.Set ("r_res",("ST_ARG("^
(intToCString ndx
)^
")")))
344 |
genExpr (VarBound (name
,major
,minor
)) absDepth
=
345 CSadd (CodeSegment
.Set ("r_res",("((int**)ST_ENV())["^
(intToCString major
)^
"]["^
(intToCString minor
)^
"]")))
346 |
genExpr (If (test
,dit
,dif
)) absDepth
=
348 val lblElse
= makeLabelElse ()
349 val lblEndif
= makeLabelEndif ()
350 val lblFalse
= DataSegment
.add (Bool false)
352 (genExpr test absDepth
353 ;CSadd (CodeSegment
.BranchIf ("(SchemeObject*)r_res==&"^lblFalse
,lblElse
))
354 ;genExpr dit absDepth
355 ;CSadd (CodeSegment
.Branch lblEndif
)
356 ;CSadd (CodeSegment
.Label lblElse
)
357 ;genExpr dif absDepth
358 ;CSadd (CodeSegment
.Label lblEndif
)
361 |
genExpr (abs
as Abs _
) absDepth
= genAbs abs absDepth
362 |
genExpr (abs
as AbsOpt _
) absDepth
= genAbs abs absDepth
363 |
genExpr (abs
as AbsVar _
) absDepth
= genAbs abs absDepth
364 |
genExpr (App (proc
,args
)) absDepth
=
365 (genDebug (App (proc
,args
));
367 val lblRet
= makeLabelRet ()
368 val lblApp
= makeLabelApp ()
370 (* for each arg
in args (backwards
) do:
372 push r_res to stack
*)
373 ((maprtl (fn arg
=> (genExpr arg absDepth
;
374 CSadd (CodeSegment
.Push
"r_res")))
376 (* push
length(args
) to stack
*)
377 ;CSadd (CodeSegment
.Push (intToCString (List.length args
)))
379 ;genExpr proc absDepth
380 (* if r_res is not a closure
then: error
*)
381 ;CSadd (CodeSegment
.BranchIf ("IS_SOB_CLOSURE(r_res)",lblApp
))
382 ;CSadd (CodeSegment
.Error ErrType
.AppNonProc
)
383 ;CSadd (CodeSegment
.Label lblApp
)
384 (* push proc
.env to stack
*)
385 ;CSadd (CodeSegment
.Push
"(int)SOB_CLOSURE_ENV(r_res)")
386 (* push return address
*)
387 ;CSadd (CodeSegment
.Push ("(int)&&"^lblRet
))
389 ;CSadd (CodeSegment
.Branch
"*(SOB_CLOSURE_CODE(r_res))")
391 ;CSadd (CodeSegment
.Label lblRet
)
392 (* restore sp
- discard
:
393 - enviroment
pointer (at sp
-1)
394 - n
, the number
of arguments (at sp
-2)
396 ;CSadd (CodeSegment
.Set ("sp","sp-2-stack[sp-2]"))
400 |
genExpr (AppTP (proc
,args
)) absDepth
=
401 (genDebug (AppTP (proc
,args
));
402 (* for each arg
in args (backwards
) do:
404 push r_res to stack
*)
405 ((maprtl (fn arg
=> (genExpr arg absDepth
;
406 CSadd (CodeSegment
.Push
"r_res")))
408 (* push
length(args
) to stack
*)
409 ;CSadd (CodeSegment
.Push (intToCString (List.length args
)))
411 ;genExpr proc absDepth
412 (* if r_res is not a closure
then: error
*)
413 ;CSadd (CodeSegment
.ErrorIf ("! IS_SOB_CLOSURE(r_res)",ErrType
.AppNonProc
))
414 (* push proc
.env to stack
*)
415 ;CSadd (CodeSegment
.Push
"(int)SOB_CLOSURE_ENV(r_res)")
416 (* push return
address (of current activation frame
) *)
417 ;CSadd (CodeSegment
.Push
"ST_RET()")
418 (* override current activation frame
*)
419 ;CSadd (CodeSegment
.Statement ("shiftActFrmDown()"))
421 ;CSadd (CodeSegment
.Branch
"*(SOB_CLOSURE_CODE(r_res))")
424 |
genExpr (Seq
[]) absDepth
= ()
425 |
genExpr (Seq (e
:: rest
)) absDepth
= (genExpr e absDepth
; genExpr (Seq rest
) absDepth
)
426 |
genExpr (Or preds
) absDepth
=
428 val lblEndOr
= makeLabelEndOr ()
430 (genOrPreds lblEndOr preds absDepth
431 ;CSadd (CodeSegment
.Label lblEndOr
)
434 |
genExpr (Set ((VarFree name
),value
)) absDepth
=
435 (* Set on VarFree is just the same
as Def on VarFree
*)
436 genExpr (Def ((VarFree name
),value
)) absDepth
437 |
genExpr (Set ((VarParam (name
,ndx
)),value
)) absDepth
=
438 let val lblVoid
= DataSegment
.add Void
440 (genExpr value absDepth
441 ;CSadd (CodeSegment
.Assertion ("("^
(intToCString ndx
)^
">=0) & ("^
(intToCString ndx
)^
"<ST_ARG_COUNT())",ErrType
.None
))
442 ;CSadd (CodeSegment
.Set (("ST_ARG("^
(intToCString ndx
)^
")"),"r_res"))
443 ;CSadd (CodeSegment
.Set ("r_res","(int)&"^lblVoid
))
446 |
genExpr (Set ((VarBound (name
,major
,minor
)),value
)) absDepth
=
447 let val lblVoid
= DataSegment
.add Void
449 (genExpr value absDepth
450 ;CSadd (CodeSegment
.Set (("((int**)ST_ENV())["^
(intToCString major
)^
"]["^
(intToCString minor
)^
"]"),"r_res"))
451 ;CSadd (CodeSegment
.Set ("r_res","(int)&"^lblVoid
))
454 |
genExpr (Def ((VarFree name
),value
)) absDepth
=
455 let val lblVoid
= DataSegment
.add Void
457 (CSadd (CodeSegment
.Debug ("binding symbol: "^name
))
458 ;genExpr value absDepth
459 ;CSadd (CodeSegment
.Set ("r[0]","(int)getSymbol(\""^name^
"\",topLevel)"))
460 ;CSadd (CodeSegment
.Set ("((SymbolEntry*)r[0])->isDefined","1"))
461 ;CSadd (CodeSegment
.Set ("((SymbolEntry*)r[0])->sob","(SchemeObject*)r_res"))
462 ;CSadd (CodeSegment
.Set ("r_res","(int)&"^lblVoid
))
465 |
genExpr (Def (_
,_
)) absDepth
= raise Match (* shouldn
't be here
*)
466 and genOrPreds _
[] absDepth
= ()
467 | genOrPreds
lblEndOr (p
:: rest
) absDepth
=
469 val lblFalse
= DataSegment
.add (Bool false)
472 ;CSadd (CodeSegment
.BranchIf ("(SchemeObject*)r_res!=&"^lblFalse
,lblEndOr
))
473 ;genOrPreds lblEndOr rest absDepth
476 and genAbs abs absDepth
=
478 val formalParams
= case abs
of
479 Abs (params
,_
) => List.length params
480 |
AbsOpt (params
,_
,_
) => List.length params
+ 1
482 | _
=> raise Match (* shouldn
't be here
*)
483 val body
= case abs
of
485 |
AbsOpt (_
,_
,body
) => body
486 |
AbsVar (_
,body
) => body
487 | _
=> raise Match (* shouldn
't be here
*)
488 val lblSkipBody
= makeLabelSkipBody ()
489 val lblBody
= makeLabelBody ()
491 (* 1. extend enviroment
*)
492 (CSadd (CodeSegment
.Set ("r[0]","(int)extendEnviroment( (int**)"^
493 (if absDepth
=0 then "NULL"
496 (intToCString absDepth
)^
498 (* 2. prepare code
*)
499 ;CSadd (CodeSegment
.Branch lblSkipBody
)
500 ;CSadd (CodeSegment
.Label lblBody
)
502 ;CSadd (CodeSegment
.Push
"fp")
503 ;CSadd (CodeSegment
.Set ("fp","sp"))
504 (* fix stack
if needed
*)
507 |
(AbsOpt _
) => CSadd (CodeSegment
.Statement ("prepareStackForAbsOpt("^
(intToCString formalParams
)^
")"))
508 |
(AbsVar _
) => CSadd (CodeSegment
.Statement ("prepareStackForAbsOpt("^
(intToCString formalParams
)^
")"))
509 | _
=> raise Match (* shouldn
't be here
*)
510 (* verify number
of actual arguments
*)
511 ;CSadd (CodeSegment
.ErrorIf ("ST_ARG_COUNT()!="^
(intToCString formalParams
),
512 (ErrType
.ArgsCount ("user-procedure",formalParams
))))
514 ;genExpr
body (absDepth
+1)
516 ;CSadd (CodeSegment
.Pop ("fp"))
517 ;CSadd CodeSegment
.Return
518 ;CSadd (CodeSegment
.Label lblSkipBody
)
519 (* 3. create closure
*)
520 ;CSadd (CodeSegment
.Set ("r_res","(int)makeSchemeClosure((void*)r[0],&&"^lblBody^
")"))
525 fun gen expr absDepth
=
527 val lblRet
= makeLabelRet ()
529 (* Set return address
- the initial frame contains a dummy
530 return address
. Here we set it to instruction after `expr`
.
531 In
case of several expressions compiled one after the other
,
532 we could pop the initial activation
frame (it was pushed
in
533 addProlog
) and push a new one
. But since the only thing that
534 changes is the return address
, we just hack it
.
536 (CSadd (CodeSegment
.Comment
"set return address")
537 ;CSadd (CodeSegment
.Set ("ST_RET()","(int)&&"^lblRet
))
538 (* Compile the expression
*)
539 ;genExpr expr absDepth
540 (* Don
't forget the return address
.. *)
541 ;CSadd (CodeSegment
.Label lblRet
)
546 fun emit (nregs
,stacksize
) =
548 "/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^
549 "#include \"scheme.h\"\n" ^
550 "#include \"assertions.h\"\n" ^
551 "#include \"arch.h\"\n" ^
552 "#include \"rtemgr.h\"\n" ^
553 "#include \"strings.h\"\n" ^
554 "extern SymbolNode *topLevel;\n"^
555 "\n/* Data Segment */\n" ^
556 (DataSegment
.emit ()) ^
557 "\n/* Code Segment */\n" ^
558 "void schemeCompiledFunction() {\n" ^
559 "\t#include \"builtins.c\"\n\n"^
560 "\tinitArchitecture("^
Int.toString(stacksize
)^
","^
Int.toString(nregs
)^
");\n" ^
562 (CodeSegment
.emit ()) ^