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
|
structure Syntax =
struct
(* SML syntax *)
datatype etype = Tyvar of string
| Tycon of etype list * string
| TyTuple of etype list
| Tyfun of etype * etype
datatype expr = EIdent of string list
| EBuiltin of string
| EInt of int
| EStr of string
| ETuple of expr list
| EList of expr list
| EApp of expr * expr
| ETyped of expr * etype
| EAndAlso of expr * expr
| EOrElse of expr * expr
| ELet of dec list * expr
and dec = DVal of expr
(* Lambda language *)
datatype primop = PExit
datatype lexp = LApp of lexp * lexp
| LInt of int
| LString of string
| LRecord of lexp list
| LPrim of primop
(* CPS *)
type var = int
datatype value = VVar of var
| VLabel of var
| VInt of int
| VString of string
datatype cexp = CRecord of (value * int list) list * var * cexp
| CSelect of int * value * var * cexp
| CApp of value * value list
| CFix of (var * var list * cexp) list * cexp
| CPrimop of primop * value list * var list * cexp list
datatype opcode = OAlloc of var * value
| OCall
| OPoke of int * var * value
| OPeek of var * int * value
| OShuf of var * value
| OExit of value
| OLabel of var
fun listToString (show : 'a -> string) (l : 'a list) =
"[" ^ String.concatWith ", " (map show l) ^ "]"
fun multilineListToString (show : string -> 'a -> string) (indent : string) (l : 'a list) =
case l of
[] => "[]"
| [x] => "[ " ^ show (indent ^ " ") x ^ " ]"
| (x :: xs) =>
let val indent' = indent ^ " "
in "[ " ^ show indent' x ^ concat (map (fn x => "\n" ^ indent ^ ", " ^ show indent' x) xs) ^ "\n" ^ indent ^ "]"
end
fun quote (s : string) : string = "\"" ^ String.toString s ^ "\""
fun etypeToString (x : etype) : string =
case x of
Tyvar s => "Tyvar " ^ quote s
| Tycon (args, con) => "Tycon (" ^ listToString etypeToString args ^ ", " ^ quote con ^ ")"
| TyTuple args => "TyTuple " ^ listToString etypeToString args
| Tyfun (a, b) => "Tyfun (" ^ etypeToString a ^ ", " ^ etypeToString b ^ ")"
fun exprToStringI (indent : string) (x : expr) : string =
let val self = exprToStringI indent
in case x of
EIdent i => "EIdent " ^ listToString quote i
| EBuiltin b => "EBuiltin " ^ quote b
| EInt i => "EInt " ^ Int.toString i
| EStr s => "EStr " ^ quote s
| ETuple xs => "ETuple " ^ listToString self xs
| EList l => "EList " ^ listToString self l
| EApp (f, x) => "EApp (" ^ self f ^ ", " ^ self x ^ ")"
| ETyped (e, t) => "ETyped (" ^ self e ^ ", " ^ etypeToString t ^ ")"
| EAndAlso (a, b) => "EAndAlso (" ^ self a ^ ", " ^ self b ^ ")"
| EOrElse (a, b) => "EOrElse (" ^ self a ^ ", " ^ self b ^ ")"
| ELet (decs, e) => "ELet (" ^ multilineListToString decToStringI indent decs ^ ", " ^ self e ^ ")"
end
and decToStringI (indent : string) (x : dec) : string =
case x of
DVal e => "DVal (" ^ exprToStringI indent e ^ ")"
val exprToString : expr -> string = exprToStringI ""
val decToString : dec -> string = decToStringI ""
fun primopToString (x : primop) : string =
case x of
PExit => "PExit"
fun lexpToString (x : lexp) : string =
case x of
LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")"
| LInt i => "LInt " ^ Int.toString i
| LString s => "LString " ^ quote s
| LRecord l => "LRecord " ^ listToString lexpToString l
| LPrim p => "LPrim " ^ primopToString p
fun valueToString (x : value) : string =
case x of
VVar v => "VVar " ^ Int.toString v
| VLabel l => "VLabel " ^ Int.toString l
| VInt i => "VInt " ^ Int.toString i
| VString s => "VString " ^ quote s
fun cexpToStringI (indent : string) (x : cexp) : string =
let
val self = cexpToStringI indent
val newIndent = indent ^ "\t"
in case x of
CRecord (a, b, c) => "CRecord (" ^ listToString (fn (x, y) => "(" ^ valueToString x ^ ", " ^ listToString Int.toString y ^ ")") a ^ ", " ^ Int.toString b ^ ",\n" ^ indent ^ self c ^ ")"
| CSelect (a, b, c, d) => "CSelect (" ^ Int.toString a ^ ", " ^ valueToString b ^ ", " ^ Int.toString c ^ ",\n" ^ indent ^ self d ^ ")"
| CApp (a, b) => "CApp (" ^ valueToString a ^ ", " ^ listToString valueToString b ^ ")"
| CFix (a, b) => "CFix (" ^ multilineListToString (fn indent' => fn (x, y, z) => "(" ^ Int.toString x ^ ", " ^ listToString Int.toString y ^ ",\n" ^ indent' ^ "\t" ^ cexpToStringI (indent' ^ "\t") z) newIndent a ^ ",\n" ^ newIndent ^ cexpToStringI newIndent b ^ ")"
| CPrimop (a, b, c, d) => "CPrimop (" ^ primopToString a ^ ", " ^ listToString valueToString b ^ ", " ^ listToString Int.toString c ^ ",\n" ^ indent ^ multilineListToString cexpToStringI indent d ^ ")"
end
val cexpToString : cexp -> string = cexpToStringI ""
end
|
