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
|
(*
Copyright (c) 2000
Cambridge University Technical Services Limited
Modified David C.J. Matthews 2008, 2013, 2015.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation;.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
structure Debug: DEBUGSIG =
struct
local
open Universal
in
(* Get the current line number. *)
val lineNumberTag: (unit->int) tag = tag()
(* Get the current offset (position on line or in file). *)
val offsetTag: (unit->int) tag = tag()
(* File name. *)
val fileNameTag: string tag = tag()
(* Binding counter *)
val bindingCounterTag: (unit->int) tag = tag()
(* How much to print in error messages? default 6 *)
val errorDepthTag: int tag = tag()
(* Control print depth in PolyML.print. *)
val printDepthFunTag: (unit->int) tag = tag()
(* Length of line in PolyML.print. error messages etc. *)
val lineLengthTag: int tag = tag()
(* Compile in debugging code? default false *)
val debugTag: bool tag = tag()
(* Compilation fine tuning. *)
(* Should functors be made inline? default true. *)
val inlineFunctorsTag: bool tag = tag()
(* Control how big functions should be before they're not inlined. *)
val maxInlineSizeTag: int tag = tag()
(* Add profile information to each allocation? default zero.
At the moment this is effectively a bool but having an int allows
for the possibility of recording different information. *)
val profileAllocationTag: int tag = tag()
(* Compiler debugging. *)
(* Trace exceptions generated within the compiler? default false. *)
val traceCompilerTag: bool tag = tag()
(* Print parsetree after parsing? default false *)
val parsetreeTag: bool tag = tag()
(* Print codetree after compiling? default false *)
val codetreeTag: bool tag = tag()
(* Print the optimised code after compiling? default false *)
val codetreeAfterOptTag: bool tag = tag()
(* Print pseudo-stack in code-generator? default false *)
val pstackTraceTag: bool tag = tag()
(* Switch on/off low-level optimisation. *)
val lowlevelOptimiseTag: bool tag = tag()
(* Print assembly code in code-generator? default false *)
val assemblyCodeTag: bool tag = tag()
(* Report unreferenced identifiers as warnings *)
val reportUnreferencedIdsTag: bool tag = tag()
(* Report catch-all handlers as warnings *)
val reportExhaustiveHandlersTag: bool tag = tag()
(* Use a narrow context to resolve overloading and flexible records. *)
val narrowOverloadFlexRecordTag: bool tag = tag()
(* Create print functions for datatypes based on the constructors. *)
val createPrintFunctionsTag: bool tag = tag()
(* Warning level for discarding values *)
val reportDiscardedValuesTag: int tag = tag()
val reportDiscardNone = 0 (* No reports *)
and reportDiscardFunction = 1 (* Only report discarded functions *)
and reportDiscardNonUnit = 2 (* Report discarding any non unit values *)
(* To avoid circularity of dependencies a few tags are defined
elsewhere: *)
(* ValueOps.printSpaceTag: ValueOps.nameSpace tag
Pretty.printOutputTag: (pretty->unit) tag
Pretty.compilerOutputTag: (pretty->unit) tag
Lex.errorMessageProcTag: (pretty * bool * int -> unit) tag
ExportTreeString.rootTreeTag: (unit -> exportTree) tag
*)
val defaults =
[
tagInject lineNumberTag (fn () => 0), (* Zero line number *)
tagInject offsetTag (fn () => 0), (* Zero offset *)
tagInject fileNameTag "",
tagInject bindingCounterTag (fn () => 0), (* Zero counter *)
tagInject inlineFunctorsTag true,
tagInject maxInlineSizeTag 80,
tagInject profileAllocationTag 0,
tagInject parsetreeTag false,
tagInject codetreeTag false,
tagInject pstackTraceTag false,
tagInject lowlevelOptimiseTag true,
tagInject assemblyCodeTag false,
tagInject codetreeAfterOptTag false,
tagInject errorDepthTag 6,
tagInject printDepthFunTag (fn () => 0),
tagInject lineLengthTag 77,
tagInject traceCompilerTag false,
tagInject debugTag false,
tagInject reportUnreferencedIdsTag false,
tagInject reportExhaustiveHandlersTag false,
tagInject narrowOverloadFlexRecordTag false,
tagInject createPrintFunctionsTag true,
tagInject reportDiscardedValuesTag reportDiscardFunction
]
fun getParameter (t:'a tag) (tagList: universal list) :'a =
case List.find (tagIs t) tagList of
SOME a => tagProject t a
| NONE => (* Use the default *)
(
case List.find (tagIs t) defaults of
SOME a => tagProject t a
| NONE => raise Misc.InternalError "tag missing"
)
end
end;
|
