Commit 573ef10b authored by partain's avatar partain

[project @ 1996-07-15 11:32:34 by partain]

partain changes to 960714
parent 30f15b4e
...@@ -37,7 +37,7 @@ SuffixRule_c_o() ...@@ -37,7 +37,7 @@ SuffixRule_c_o()
*/ */
SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */ SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */
utils:basicTypes:types:hsSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser utils:basicTypes:types:hsSyn:prelude:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
#ifdef MainIncludeDir #ifdef MainIncludeDir
MAIN_INCLUDE_DIR=MainIncludeDir MAIN_INCLUDE_DIR=MainIncludeDir
...@@ -365,21 +365,21 @@ BACKSRCS_LHS NATIVEGEN_SRCS_LHS ...@@ -365,21 +365,21 @@ BACKSRCS_LHS NATIVEGEN_SRCS_LHS
# define loop_hi(f) CAT2(f,.hi) # define loop_hi(f) CAT2(f,.hi)
#endif #endif
DELOOP_HIs = \ DELOOP_HIs = \
utils/Ubiq.hi \ loop_hi(utils/Ubiq) \
absCSyn/AbsCLoop.hi \ loop_hi(absCSyn/AbsCLoop) \
basicTypes/IdLoop.hi \ loop_hi(basicTypes/IdLoop) \
codeGen/CgLoop1.hi \ loop_hi(codeGen/CgLoop1) \
codeGen/CgLoop2.hi \ loop_hi(codeGen/CgLoop2) \
deSugar/DsLoop.hi \ loop_hi(deSugar/DsLoop) \
hsSyn/HsLoop.hi \ loop_hi(hsSyn/HsLoop) \
nativeGen/NcgLoop.hi \ loop_hi(nativeGen/NcgLoop) \
prelude/PrelLoop.hi \ loop_hi(prelude/PrelLoop) \
rename/RnLoop.hi \ loop_hi(rename/RnLoop) \
simplCore/SmplLoop.hi \ loop_hi(simplCore/SmplLoop) \
typecheck/TcMLoop.hi \ loop_hi(typecheck/TcMLoop) \
typecheck/TcLoop.hi \ loop_hi(typecheck/TcLoop) \
types/TyLoop.hi loop_hi(types/TyLoop)
/* /*
\ \
...@@ -441,6 +441,10 @@ HC = $(GHC) /* uses the driver herein */ ...@@ -441,6 +441,10 @@ HC = $(GHC) /* uses the driver herein */
BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a) BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a)
parser/hschooks.o : parser/hschooks.c
$(RM) $@
$(HC) -c -o $@ $(HCFLAGS) parser/hschooks.c
#if DoInstallGHCSystem == YES #if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC)) MakeDirectories(install, $(INSTLIBDIR_GHC))
InstallBinaryTarget(hsc,$(INSTLIBDIR_GHC)) InstallBinaryTarget(hsc,$(INSTLIBDIR_GHC))
...@@ -512,7 +516,7 @@ compile(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances)) ...@@ -512,7 +516,7 @@ compile(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
compile(hsSyn/HsBinds,lhs,) compile(hsSyn/HsBinds,lhs,)
compile(hsSyn/HsCore,lhs,) compile(hsSyn/HsCore,lhs,)
compile(hsSyn/HsDecls,lhs,) compile(hsSyn/HsDecls,lhs,)
compile(hsSyn/HsExpr,lhs,) compile(hsSyn/HsExpr,lhs,if_ghc(-K2m))
compile(hsSyn/HsImpExp,lhs,) compile(hsSyn/HsImpExp,lhs,)
compile(hsSyn/HsLit,lhs,) compile(hsSyn/HsLit,lhs,)
compile(hsSyn/HsMatches,lhs,) compile(hsSyn/HsMatches,lhs,)
...@@ -586,7 +590,7 @@ compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR)) ...@@ -586,7 +590,7 @@ compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR) if_ghc(-K2m))
compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/Stix,lhs,) compile(nativeGen/Stix,lhs,)
compile(nativeGen/StixInfo,lhs,) compile(nativeGen/StixInfo,lhs,)
...@@ -617,7 +621,7 @@ compile(rename/RnHsSyn,lhs,) ...@@ -617,7 +621,7 @@ compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C)) compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,) compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,) compile(rename/RnNames,lhs,)
compile(rename/RnSource,lhs,) compile(rename/RnSource,lhs,-H12m)
compile(rename/RnBinds,lhs,) compile(rename/RnBinds,lhs,)
compile(rename/RnExpr,lhs,) compile(rename/RnExpr,lhs,)
compile(rename/RnIfaces,lhs,) compile(rename/RnIfaces,lhs,)
...@@ -807,7 +811,7 @@ UgenNeededHere(all depend) ...@@ -807,7 +811,7 @@ UgenNeededHere(all depend)
NormalLibraryTarget(hsp,$(HSP_OBJS_O)) NormalLibraryTarget(hsp,$(HSP_OBJS_O))
/* We need the hsp program for hstags to work! */ /* We need the hsp program for hstags to work! */
BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a) /* BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a) */
#if DoInstallGHCSystem == YES #if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC)) MakeDirectories(install, $(INSTLIBDIR_GHC))
...@@ -874,6 +878,11 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"') ...@@ -874,6 +878,11 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
#if GhcBuilderVersion < 200
/* this will go away soon enough... (once 1.3 is settled in) */
MKDEPENDHS = mkdependHS-1.2
#endif
#if GhcWithHscBuiltViaC == NO #if GhcWithHscBuiltViaC == NO
MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#else /* booting from .hc */ #else /* booting from .hc */
......
...@@ -75,6 +75,7 @@ module Id ( ...@@ -75,6 +75,7 @@ module Id (
isTopLevId, isTopLevId,
isTupleCon, isTupleCon,
isWorkerId, isWorkerId,
isWrapperId,
toplevelishId, toplevelishId,
unfoldingUnfriendlyId, unfoldingUnfriendlyId,
...@@ -101,6 +102,7 @@ module Id ( ...@@ -101,6 +102,7 @@ module Id (
getIdUnfolding, getIdUnfolding,
getIdUpdateInfo, getIdUpdateInfo,
getPragmaInfo, getPragmaInfo,
replaceIdInfo,
-- IdEnvs AND IdSets -- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet), SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
...@@ -606,9 +608,7 @@ isSuperDictSelId_maybe other_id = Nothing ...@@ -606,9 +608,7 @@ isSuperDictSelId_maybe other_id = Nothing
isWorkerId (Id _ _ _ (WorkerId _) _ _) = True isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False isWorkerId other = False
{-LATER:
isWrapperId id = workerExists (getIdStrictness id) isWrapperId id = workerExists (getIdStrictness id)
-}
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -778,7 +778,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad ...@@ -778,7 +778,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad
-> Bool -- mentions this Id. Reason: it cannot -> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module. -- possibly be seen in another module.
unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId" unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
{-LATER: {-LATER:
unfoldingUnfriendlyId id unfoldingUnfriendlyId id
...@@ -1213,11 +1213,11 @@ getPragmaInfo :: GenId ty -> PragmaInfo ...@@ -1213,11 +1213,11 @@ getPragmaInfo :: GenId ty -> PragmaInfo
getIdInfo (Id _ _ _ _ _ info) = info getIdInfo (Id _ _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ _ info _) = info getPragmaInfo (Id _ _ _ _ info _) = info
{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id replaceIdInfo :: Id -> IdInfo -> Id
replaceIdInfo (Id u n ty _ details) info = Id u n ty info details replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
{-LATER:
selectIdInfoForSpecId :: Id -> IdInfo selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec))) = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
......
...@@ -567,7 +567,7 @@ or an Absent {\em that we accept}. ...@@ -567,7 +567,7 @@ or an Absent {\em that we accept}.
indicatesWorker :: [Demand] -> Bool indicatesWorker :: [Demand] -> Bool
indicatesWorker dems indicatesWorker dems
= fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
where where
fake_mk_ww _ [] = False fake_mk_ww _ [] = False
fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
......
...@@ -71,8 +71,6 @@ import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, ...@@ -71,8 +71,6 @@ import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
pprUnique, Unique pprUnique, Unique
) )
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} ) import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} )
import {-hide from mkdependHS-}
RnHsSyn ( RnName ) -- instance for specializing only
#ifdef REALLY_HASKELL_1_3 #ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int ord = fromEnum :: Char -> Int
...@@ -269,7 +267,9 @@ mkCompoundName :: Unique ...@@ -269,7 +267,9 @@ mkCompoundName :: Unique
-> Name -- from which we get provenance, etc.... -> Name -- from which we get provenance, etc....
-> Name -- result! -> Name -- result!
mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?" mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
= Local u str True{-emph uniq-} locn
mkCompoundName u m str ns (Global _ _ _ prov exp _) mkCompoundName u m str ns (Global _ _ _ prov exp _)
= Global u m (Right (Right str : ns)) prov exp [] = Global u m (Right (Right str : ns)) prov exp []
...@@ -304,9 +304,9 @@ mkTupleTyConName arity ...@@ -304,9 +304,9 @@ mkTupleTyConName arity
mkTupNameStr 0 = SLIT("()") mkTupNameStr 0 = SLIT("()")
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
mkTupNameStr 3 = SLIT("(,,)") -- ditto mkTupNameStr 3 = _PK_ "(,,)" -- ditto
mkTupNameStr 4 = SLIT("(,,,)") -- ditto mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
mkTupNameStr n mkTupNameStr n
= _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
......
...@@ -77,7 +77,7 @@ unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line)) ...@@ -77,7 +77,7 @@ unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))
\begin{code} \begin{code}
instance Outputable SrcLoc where instance Outputable SrcLoc where
ppr PprForUser (SrcLoc src_file src_line) ppr PprForUser (SrcLoc src_file src_line)
= ppBesides [ ppChar '"', ppPStr src_file, ppPStr SLIT("\", line "), ppPStr src_line ] = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
ppr sty (SrcLoc src_file src_line) ppr sty (SrcLoc src_file src_line)
= ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP, = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
......
...@@ -112,8 +112,6 @@ module Unique ( ...@@ -112,8 +112,6 @@ module Unique (
liftTyConKey, liftTyConKey,
listTyConKey, listTyConKey,
ltDataConKey, ltDataConKey,
mainIdKey,
mainPrimIOIdKey,
monadClassKey, monadClassKey,
monadPlusClassKey, monadPlusClassKey,
monadZeroClassKey, monadZeroClassKey,
...@@ -615,8 +613,6 @@ integerPlusTwoIdKey = mkPreludeMiscIdUnique 14 ...@@ -615,8 +613,6 @@ integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
integerZeroIdKey = mkPreludeMiscIdUnique 15 integerZeroIdKey = mkPreludeMiscIdUnique 15
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
lexIdKey = mkPreludeMiscIdUnique 17 lexIdKey = mkPreludeMiscIdUnique 17
mainIdKey = mkPreludeMiscIdUnique 18
mainPrimIOIdKey = mkPreludeMiscIdUnique 19
noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20 noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22 nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
......
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
% %
\section[CgClosure]{Code generation for closures} \section[CgClosure]{Code generation for closures}
...@@ -49,7 +49,7 @@ import ClosureInfo -- lots and lots of stuff ...@@ -49,7 +49,7 @@ import ClosureInfo -- lots and lots of stuff
import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros ) import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed, noCostCentreAttached, costsAreSubsumed,
isCafCC, isDictCC, overheadCostCentre isCafCC, isDictCC, overheadCostCentre, showCostCentre
) )
import HeapOffs ( SYN_IE(VirtualHeapOffset) ) import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep, import Id ( idType, idPrimRep,
...@@ -59,13 +59,14 @@ import Id ( idType, idPrimRep, ...@@ -59,13 +59,14 @@ import Id ( idType, idPrimRep,
) )
import ListSetOps ( minusList ) import ListSetOps ( minusList )
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
import PprStyle ( PprStyle(..) ) import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr ) import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
import PrimRep ( isFollowableRep, PrimRep(..) ) import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons ) import TyCon ( isPrimTyCon, tyConDataCons )
import Unpretty ( uppShow ) import Unpretty ( uppShow )
import Util ( isIn, panic, pprPanic, assertPanic ) import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)" myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)" showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
...@@ -409,8 +410,12 @@ closureCodeBody binder_info closure_info cc [] body ...@@ -409,8 +410,12 @@ closureCodeBody binder_info closure_info cc [] body
body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
body_code = profCtrC SLIT("ENT_THK") [] `thenC` body_code = profCtrC SLIT("ENT_THK") [] `thenC`
enterCostCentreCode closure_info cc IsThunk `thenC` thunkWrapper closure_info (
thunkWrapper closure_info (cgExpr body) -- We only enter cc after setting up update so that cc
-- of enclosing scope will be recorded in update frame
-- CAF/DICT functions will be subsumed by this enclosing cc
enterCostCentreCode closure_info cc IsThunk `thenC`
cgExpr body)
stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code} \end{code}
...@@ -580,9 +585,9 @@ Node is guaranteed to point to it, if profiling and not inherited. ...@@ -580,9 +585,9 @@ Node is guaranteed to point to it, if profiling and not inherited.
\begin{code} \begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local data IsThunk = IsThunk | IsFunction -- Bool-like, local
#ifdef DEBUG --#ifdef DEBUG
deriving Eq deriving Eq
#endif --#endif
enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
...@@ -594,8 +599,9 @@ enterCostCentreCode closure_info cc is_thunk ...@@ -594,8 +599,9 @@ enterCostCentreCode closure_info cc is_thunk
ASSERT(not (noCostCentreAttached cc)) ASSERT(not (noCostCentreAttached cc))
if costsAreSubsumed cc then if costsAreSubsumed cc then
ASSERT(isToplevClosure closure_info) --ASSERT(isToplevClosure closure_info)
ASSERT(is_thunk == IsFunction) --ASSERT(is_thunk == IsFunction)
(if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
costCentresC SLIT("ENTER_CC_FSUB") [] costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then else if currentOrSubsumedCosts cc then
...@@ -704,8 +710,8 @@ thunkWrapper closure_info thunk_code ...@@ -704,8 +710,8 @@ thunkWrapper closure_info thunk_code
let let
emit_gran_macros = opt_GranMacros emit_gran_macros = opt_GranMacros
in in
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones) -- (we prefer fetchAndReschedule-style context switches to yield ones)
(if emit_gran_macros (if emit_gran_macros
then if node_points then if node_points
then fetchAndReschedule [] node_points then fetchAndReschedule [] node_points
...@@ -714,19 +720,20 @@ thunkWrapper closure_info thunk_code ...@@ -714,19 +720,20 @@ thunkWrapper closure_info thunk_code
stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
-- Must be after stackCheck: if stchk fails new stack -- heapCheck must be after stackCheck: if stchk fails
-- space has to be allocated from the heap -- new stack space is allocated from the heap which
-- would violate any previous heapCheck
heapCheck [] node_points ( heapCheck [] node_points ( -- heapCheck *encloses* the rest
-- heapCheck *encloses* the rest -- The "[]" says there are no live argument registers
-- The "[]" says there are no live argument registers
-- Overwrite with black hole if necessary -- Overwrite with black hole if necessary
blackHoleIt closure_info `thenC` blackHoleIt closure_info `thenC`
-- Push update frame if necessary setupUpdate closure_info ( -- setupUpdate *encloses* the rest
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
thunk_code -- Finally, do the business
thunk_code
))) )))
funWrapper :: ClosureInfo -- Closure whose code body this is funWrapper :: ClosureInfo -- Closure whose code body this is
...@@ -744,11 +751,11 @@ funWrapper closure_info arg_regs fun_body ...@@ -744,11 +751,11 @@ funWrapper closure_info arg_regs fun_body
then yield arg_regs node_points then yield arg_regs node_points
else absC AbsCNop) `thenC` else absC AbsCNop) `thenC`
stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest stackCheck closure_info arg_regs node_points (
-- stackCheck *encloses* the rest
-- Heap overflow check
heapCheck arg_regs node_points ( heapCheck arg_regs node_points (
-- heapCheck *encloses* the rest -- heapCheck *encloses* the rest
-- Finally, do the business -- Finally, do the business
fun_body fun_body
......
...@@ -10,22 +10,22 @@ monadic stuff fits into the Big Picture. ...@@ -10,22 +10,22 @@ monadic stuff fits into the Big Picture.
#include "HsVersions.h" #include "HsVersions.h"
module CgMonad ( module CgMonad (
Code(..), -- type SYN_IE(Code), -- type
FCode(..), -- type SYN_IE(FCode), -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC, returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval, forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC, forkEvalHelp, forkAbsC,
SemiTaggingStuff(..), SYN_IE(SemiTaggingStuff),
addBindC, addBindsC, modifyBindC, lookupBindC, addBindC, addBindsC, modifyBindC, lookupBindC,
EndOfBlockInfo(..), EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo, setEndOfBlockInfo, getEndOfBlockInfo,
AStackUsage(..), BStackUsage(..), HeapUsage(..), SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
StubFlag, StubFlag,
isStubbed, isStubbed,
......
...@@ -90,7 +90,7 @@ import IdInfo ( arityMaybe ) ...@@ -90,7 +90,7 @@ import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool ) import Maybes ( assocMaybe, maybeToBool )
import Name ( isLocallyDefined, nameOf, origName ) import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) ) import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} ) import PprType ( getTyDescription, GenType{-instance Outputable-} )
import Pretty--ToDo:rm import Pretty--ToDo:rm
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness ) import PrimRep ( getPrimRepSize, separateByPtrFollowness )
...@@ -100,8 +100,6 @@ import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking, ...@@ -100,8 +100,6 @@ import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
mkFunTys, maybeAppSpecDataTyConExpandingDicts mkFunTys, maybeAppSpecDataTyConExpandingDicts
) )
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code} \end{code}
The ``wrapper'' data type for closure information: The ``wrapper'' data type for closure information:
......
...@@ -316,7 +316,8 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr ...@@ -316,7 +316,8 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
size_alg_alt (con,args,rhs) = size_up rhs size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap -- Don't charge for args, so that wrappers look cheap
(tycon, _, _) = trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts scrut_ty
size_up_alts _ (PrimAlts alts deflt) size_up_alts _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
......
...@@ -265,6 +265,28 @@ ppr_expr pe expr@(App _ _) ...@@ -265,6 +265,28 @@ ppr_expr pe expr@(App _ _)
]) ])
ppr_expr pe (Case expr alts) ppr_expr pe (Case expr alts)
| only_one_alt alts
-- johan thinks that single case patterns should be on same line as case,
-- and no indent; all sane persons agree with him.
= let
ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
= ppCat [ppr_alt_con con (pCon pe con),
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
in
ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
ppBeside (ppr_rhs alts) (ppStr "}")]
| otherwise -- default "case" printing
= ppSep = ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"], [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts), ppNest 2 (ppr_alts pe alts),
...@@ -303,6 +325,15 @@ ppr_expr pe (Coerce c ty expr) ...@@ -303,6 +325,15 @@ ppr_expr pe (Coerce c ty expr)
where where
pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v) pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v) pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
only_one_alt (PrimAlts [] (BindDefault _ _)) = True
only_one_alt (PrimAlts (_:[]) NoDefault) = True
only_one_alt _ = False
ppr_alt_con con pp_con
= if isSymLexeme con then ppParens pp_con else pp_con
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -314,14 +345,11 @@ ppr_alts pe (AlgAlts alts deflt) ...@@ -314,14 +345,11 @@ ppr_alts pe (AlgAlts alts deflt)
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]