Commit 6ecd9b9b authored by dimitris's avatar dimitris
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents a04583ac 6ae696a1
......@@ -1017,7 +1017,7 @@ defaultLogAction :: LogAction
defaultLogAction dflags severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> hPrintDump dflags stdout msg
SevDump -> printSDoc (msg $$ blankLine) style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
......
......@@ -230,6 +230,9 @@ mkDumpDoc hdr doc
-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
--
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
= do let mFile = chooseDumpFile dflags dflag
......@@ -247,12 +250,18 @@ dumpSDoc dflags dflag hdr doc
writeIORef gdref (Set.insert fileName gd)
createDirectoryIfMissing True (takeDirectory fileName)
handle <- openFile fileName mode
hPrintDump dflags handle doc
let doc'
| null hdr = doc
| otherwise = doc $$ blankLine
defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
hClose handle
-- write the dump to stdout
Nothing
-> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
Nothing -> do
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
-- | Choose where to put a dump file based on DynFlags
......
......@@ -586,7 +586,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
= WARN( debugIsOn && (max_iterations > 2)
, hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations
, hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
map (int . simplCountN) (reverse counts_so_far)))
......
......@@ -1571,21 +1571,22 @@ tryRules env rules fn args call_cont
where
trace_dump dflags rule rule_rhs
| dopt Opt_D_dump_rule_rewrites dflags
= liftIO . dumpSDoc dflags Opt_D_dump_rule_rewrites "" $
vcat [text "Rule fired",
text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont]
= log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
[ text "Rule:" <+> ftext (ru_name rule)
, text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
, text "After: " <+> pprCoreExpr rule_rhs
, text "Cont: " <+> ppr call_cont ]
| dopt Opt_D_dump_rule_firings dflags
= liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $
vcat [text "Rule fired",
ftext (ru_name rule)]
= log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
ftext (ru_name rule)
| otherwise
= return ()
log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $
sep [text hdr, nest 4 details]
\end{code}
Note [Rules for recursive functions]
......
......@@ -726,7 +726,7 @@ match_co :: RuleEnv
match_co renv subst (CoVarCo cv) co
= match_var renv subst cv (Coercion co)
match_co _ _ co1 _
= pprTrace "match_co baling out" (ppr co1) Nothing
= pprTrace "match_co bailing out" (ppr co1) Nothing
-------------
rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
......
......@@ -38,7 +38,6 @@ module Outputable (
colBinder, bold, keyword,
-- * Converting 'SDoc' into strings and outputing it
hPrintDump,
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
showSDoc, showSDocOneLine,
......@@ -91,7 +90,7 @@ import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import System.IO ( Handle, hFlush )
import System.IO ( Handle )
import System.FilePath
......@@ -330,13 +329,6 @@ ifPprDebug d = SDoc $ \ctx ->
\end{code}
\begin{code}
hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
hPrintDump dflags h doc = do
Pretty.printDoc PageMode (pprCols dflags) h
(runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser dflags handle unqual doc
......
......@@ -402,13 +402,13 @@ $(eval $(call addPackage,array))
$(eval $(call addPackage,deepseq))
$(eval $(call addPackage,bytestring))
$(eval $(call addPackage,containers))
$(eval $(call addPackage,old-locale))
$(eval $(call addPackage,old-time))
$(eval $(call addPackage,time))
$(eval $(call addPackage,Win32,($$(Windows),YES)))
$(eval $(call addPackage,unix,($$(Windows),NO)))
$(eval $(call addPackage,old-locale))
$(eval $(call addPackage,old-time))
$(eval $(call addPackage,time))
$(eval $(call addPackage,directory))
$(eval $(call addPackage,process))
$(eval $(call addPackage,haskell98))
......
exec "$executablename" -B"$topdir" ${1+"$@"} -pgma "$pgmgcc" -pgmc "$pgmgcc" -pgml "$pgmgcc"
/* -----------------------------------------------------------------------------
*
* (c) The University of Glasgow 2004
* (c) The University of Glasgow 2004-2012
*
* This file is included at the top of all .cmm source files (and
* *only* .cmm files). It defines a collection of useful macros for
......@@ -50,7 +50,7 @@
* StgTSO_what_next(CurrentTSO) = x
*
* where the StgTSO_what_next() macro is automatically generated by
* mkDerivedConstnants.c. If you need to access a field that doesn't
* mkDerivedConstants.c. If you need to access a field that doesn't
* already have a macro, edit that file (it's pretty self-explanatory).
*
* -------------------------------------------------------------------------- */
......
## This script rewrites normal C structs into successively
## greater ones so that field offset computation becomes a
## sizeof lookup and thus amenable to compile-time computations.
## Usage: pipe stg/Regs.h into 'awk' running this script
## to obtain a .c file that can be compiled to .o
## with the gcc from the cross toolchain. Then
## use another 'awk' script to process the 'nm'
## output of the object file.
## Motivation: since in general we can not run executables
## created by the cross toolchain, we need another
## way of finding out field offsets and type sizes
## of the target platform.
BEGIN {
interesting = 0
seed = 0
print "/* this file is generated by mkDerivedConstants.cross.awk, do not touch */"
print "/* needs to be compiled with the target gcc */"
print ""
print "#include \"Rts.h\""
print "#include \"Capability.h\""
print ""
## these do not have a proper typedef; supply them here
print "#define FLAG_STRUCT_TYPE(IT) typedef struct IT ## _FLAGS IT ## _FLAGS"
print "FLAG_STRUCT_TYPE(GC);"
print "FLAG_STRUCT_TYPE(DEBUG);"
print "FLAG_STRUCT_TYPE(COST_CENTRE);"
print "FLAG_STRUCT_TYPE(PROFILING);"
print "FLAG_STRUCT_TYPE(TRACE);"
print "FLAG_STRUCT_TYPE(CONCURRENT);"
print "FLAG_STRUCT_TYPE(MISC);"
print "FLAG_STRUCT_TYPE(PAR);"
print "FLAG_STRUCT_TYPE(TICKY);"
## these we do know how to get the field size,
## so do not bother mining it
print "#define DO_NOT_MINE_UNION_MEMBER(STRUCT, NESTED_MEMBER, ID) char nestedfieldsize$ ## STRUCT ## $ ## ID [sizeof ((STRUCT*)0)->NESTED_MEMBER]"
print "DO_NOT_MINE_UNION_MEMBER(StgHeader, prof.hp.ldvw, prof_hp_ldvw);"
print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraFwd, b.bitmap, b_bitmap);"
print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraRev, b.bitmap, b_bitmap);"
}
## pass through embedded unions
eat_union && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
sub(/^[ \t]*}[ \t]*/, "")
sub(/[ \t]*;[ \t]*$/, "")
new_offset_struct_name = struct_name $0
print ""
eat_union = 0
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $0 ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $0 ") ? 1 : -1];"
}
offset_struct_name = new_offset_struct_name
next
}
eat_union {
next
}
/# [0-9]* "rts\// {
ours = 1
next
}
/# [0-9]* "includes\// {
ours = 1
next
}
## filter out non-ghc headers
/# [0-9]* "/ {
ours = 0
next
}
!ours {
next
}
!interesting {
struct_name = "$" seed "$"
offset_struct_name = ""
known_struct_name = ""
eat_union = 0
assumptions = ""
}
## kill empty line
/^[ \t]*$/ {
next
}
/^# [0-9]/ {
print
next
}
/^typedef struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ {
if (interesting) error "previous struct not closed?"
interesting = 1
print ""
print "/* ### Creating offset structs for " $3 " ### */"
next
}
/^struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ {
if (interesting) error "previous struct not closed?"
interesting = 1
known_struct_name = $2
sub(/_$/, "", known_struct_name);
print ""
print "/* ### Creating offset structs for " known_struct_name " ### */"
print "char associate$" known_struct_name "$" seed ";"
next
}
## end of struct
##
interesting && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/{
sub(/;$/, "", $2)
print "char associate$" $2 "$" seed ";"
print "char SIZEOF$" seed "[sizeof(" $2 ")];"
print ""
print ""
gsub(/\^\^\^/, $2, assumptions);
print assumptions
++seed
interesting = 0
next
}
## Ptr-typedef
interesting && /^[ \t]*}[ \t]*\*[_0-9a-zA-Z][_0-9a-zA-Z]*Ptr[ \t]*;[ \t]*$/{
sub(/Ptr;$/, "", $2)
sub(/^\*/, "", $2)
print "char associate$" $2 "$" seed ";"
print "char SIZEOF$" seed "[sizeof(" $2 ")];"
print ""
print ""
gsub(/\^\^\^/, $2, assumptions);
print assumptions
++seed
interesting = 0
next
}
interesting && /^[ \t]*}[; \t]*$/ {
print "char SIZEOF$" seed "[sizeof(" known_struct_name ")];"
print ""
print ""
gsub(/\^\^\^/, known_struct_name, assumptions);
print assumptions
++seed
interesting = 0
}
# collapse whitespace after '*'
interesting {
# normalize some types
sub(/struct StgClosure_[ \t]*\*/, "StgClosure *")
gsub(/\*[ \t]*volatile/, "*")
# group stars together
gsub(/\*[ \t]*/, "*")
sub(/\*/, " *")
print "// " $0
# remove volatile
sub(/[ \t]volatile[ \t]/, " ")
# remove const
sub(/[ \t]const[ \t]/, " ")
}
## (pointer to struct) member of struct
##
interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*\*[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
if (!$4) {
sub(/^\*/, "", $3)
$4 = $3
}
sub(/;$/, "", $4)
new_offset_struct_name = struct_name $4
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $4 ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $4 ") ? 1 : -1];"
}
print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 "*)];"
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
## (simple pointer) member of struct
##
interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\*\**[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
sub(/;$/, "", $2)
sub(/^\**/, "", $2)
new_offset_struct_name = struct_name $2
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];"
}
print "char fieldsize" new_offset_struct_name "[sizeof(" $1 "*)];"
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
## member of struct
##
interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ {
sub(/;$/, "", $2)
new_offset_struct_name = struct_name $2
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];"
}
print "char fieldsize" new_offset_struct_name "[sizeof(" $1 ")];"
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
## struct member of struct
##
interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ {
sub(/;$/, "", $3)
new_offset_struct_name = struct_name $3
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $3 ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $3 ") ? 1 : -1];"
}
print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 ")];"
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
## embedded union
interesting && /^[ \t]*union[ \t]*{[ \t]*$/ {
eat_union = 1
next
}
## array member
interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\**[_0-9a-zA-Z][_0-9a-zA-Z]*\[.*\];[ \t]*$/ {
sub(/;[ \t]*$/, "", $0)
full = $0
sub(/^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*/, "", full)
split(full, parts, "[")
mname = parts[1]
sub(/^\**/, "", mname)
new_offset_struct_name = struct_name mname
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];"
}
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
## padded member of struct
## of this form: StgHalfInt slow_apply_offset; StgHalfWord __pad_slow_apply_offset;;
##
interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*__pad_[a-zA-Z][_0-9a-zA-Z]*;;*[ \t]*$/ {
mname = $2
sub(/;$/, "", mname)
new_offset_struct_name = struct_name mname
print ""
if (!offset_struct_name)
{
print "char starting" new_offset_struct_name "[2];"
}
else
{
assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];"
assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];"
}
print ""
print ""
offset_struct_name = new_offset_struct_name
next
}
interesting && /;[ \t]*$/ {
print "Member not recognized: " $0 > "/dev/stderr"
exit 1
}
\ No newline at end of file
BEGIN {
print "#define OFFSET(s_type, field) OFFSET_ ## s_type ## _ ## field"
print "#define FIELD_SIZE(s_type, field) FIELD_SIZE_ ## s_type ## _ ## field"
print "#define TYPE_SIZE(type) TYPE_SIZE_ ## type"
print ""
}
/^0[0-9a-zA-Z]* C _*associate\$/ {
sub(/_*associate\$/, "", $3)
split($3, arr, "$")
assoc[arr[2]] = arr[1]
next
}
/^00*2 C _*starting\$[0-9]*\$[_0-9a-zA-Z]*$/ {
sub(/_*starting\$/, "", $3)
split($3, arr, "$")
sub(/^0*/, "", $1)
print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x0"
next
}
/^0[0-9a-zA-Z]* C _*sizeof\$[0-9]*\$[_0-9a-zA-Z]*$/ {
sub(/_*sizeof\$/, "", $3)
split($3, arr, "$")
sub(/^0*/, "", $1)
print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x" $1
next
}
/^0[0-9a-zA-Z]* C _*fieldsize\$[0-9]*\$[_0-9a-zA-Z]*$/ {
sub(/_*fieldsize\$/, "", $3)
split($3, arr, "$")
sub(/^0*/, "", $1)
print "#define FIELD_SIZE_" assoc[arr[1]] "_" arr[2] " 0x" $1 "UL"
next
}
/^0[0-9a-zA-Z]* C _*nestedfieldsize\$[_0-9a-zA-Z]*\$[_0-9a-zA-Z]*$/ {
sub(/_*nestedfieldsize\$/, "", $3)
split($3, arr, "$")
sub(/^0*/, "", $1)
print "#define FIELD_SIZE_" arr[1] "_" arr[2] " 0x" $1 "UL"
next
}
/^0[0-9a-zA-Z]* C _*SIZEOF\$[0-9]*$/ {
sub(/_*SIZEOF\$/, "", $3)
sub(/^0*/, "", $1)
print "#define TYPE_SIZE_" assoc[$3] " 0x" $1
next
}
{ print "// " $0 }
END {
## some indirect offsets
print "#define OFFSET_StgHeader_prof_ccs (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_ccs)"
print "#define OFFSET_StgHeader_prof_hp_ldvw (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_hp + 0)"
print "#define OFFSET_StgTSO_prof_cccs (OFFSET_StgTSO_prof + OFFSET_StgTSOProfInfo_cccs)"
print "#define OFFSET_RTS_FLAGS_ProfFlags_showCCSOnException (OFFSET_RTS_FLAGS_ProfFlags + OFFSET_PROFILING_FLAGS_showCCSOnException)"
print "#define OFFSET_RTS_FLAGS_DebugFlags_apply (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_apply)"
print "#define OFFSET_RTS_FLAGS_DebugFlags_sanity (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_sanity)"
print "#define OFFSET_RTS_FLAGS_DebugFlags_weak (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_weak)"
print "#define OFFSET_RTS_FLAGS_GcFlags_initialStkSize (OFFSET_RTS_FLAGS_GcFlags + OFFSET_GC_FLAGS_initialStkSize)"
print "#define OFFSET_RTS_FLAGS_MiscFlags_tickInterval (OFFSET_RTS_FLAGS_MiscFlags + OFFSET_MISC_FLAGS_tickInterval)"
print "#define OFFSET_StgFunInfoExtraFwd_b_bitmap (OFFSET_StgFunInfoExtraFwd_b + 0)"
print "#define OFFSET_StgFunInfoExtraRev_b_bitmap (OFFSET_StgFunInfoExtraRev_b + 0)"
## some indirect field sizes
print "#define FIELD_SIZE_StgHeader_prof_ccs FIELD_SIZE_StgProfHeader_ccs"
print "#define FIELD_SIZE_StgTSO_prof_cccs FIELD_SIZE_StgTSOProfInfo_cccs"
print "#define FIELD_SIZE_RTS_FLAGS_ProfFlags_showCCSOnException FIELD_SIZE_PROFILING_FLAGS_showCCSOnException"
print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_apply FIELD_SIZE_DEBUG_FLAGS_apply"
print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_sanity FIELD_SIZE_DEBUG_FLAGS_sanity"
print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_weak FIELD_SIZE_DEBUG_FLAGS_weak"
print "#define FIELD_SIZE_RTS_FLAGS_GcFlags_initialStkSize FIELD_SIZE_GC_FLAGS_initialStkSize"
print "#define FIELD_SIZE_RTS_FLAGS_MiscFlags_tickInterval FIELD_SIZE_MISC_FLAGS_tickInterval"
}
/* -----------------------------------------------------------------------------
*
* (c) The GHC Team, 2009
* (c) The GHC Team, 2009-2012
*
* Macros for profiling operations in STG code
*
......@@ -107,7 +107,7 @@ typedef struct IndexTable_ {
CostCentre *cc;
CostCentreStack *ccs;
struct IndexTable_ *next;
unsigned int back_edge;
nat back_edge;
} IndexTable;