Commit 111cee3f authored by simonpj's avatar simonpj
Browse files

[project @ 2000-03-23 17:45:17 by simonpj]

This utterly gigantic commit is what I've been up to in background
mode in the last couple of months.  Originally the main goal
was to get rid of Con (staturated constant applications)
in the CoreExpr type, but one thing led to another, and I kept
postponing actually committing.   Sorry.

	Simon, 23 March 2000


I've tested it pretty thoroughly, but doubtless things will break.

Here are the highlights

* Con is gone; the CoreExpr type is simpler
* NoRepLits have gone
* Better usage info in interface files => less recompilation
* Result type signatures work
* CCall primop is tidied up
* Constant folding now done by Rules
* Lots of hackery in the simplifier
* Improvements in CPR and strictness analysis

Many bug fixes including

* Sergey's DoCon compiles OK; no loop in the strictness analyser
* Volker Wysk's programs don't crash the CPR analyser

I have not done much on measuring compilation times and binary sizes;
they could have got worse.  I think performance has got significantly
better, though, in most cases.


Removing the Con form of Core expressions
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The big thing is that

  For every constructor C there are now *two* Ids:

	C is the constructor's *wrapper*. It evaluates and unboxes arguments
	before calling $wC.  It has a perfectly ordinary top-level defn
	in the module defining the data type.

	$wC is the constructor's *worker*.  It is like a primop that simply
	allocates and builds the constructor value.  Its arguments are the
	actual representation arguments of the constructor.
	Its type may be different to C, because:
		- useless dict args are dropped
		- strict args may be flattened

  For every primop P there is *one* Id, its (curried) Id

  Neither contructor worker Id nor the primop Id have a defminition anywhere.
  Instead they are saturated during the core-to-STG pass, and the code generator
  generates code for them directly. The STG language still has saturated
  primops and constructor applications.

* The Const type disappears, along with Const.lhs.  The literal part
  of Const.lhs reappears as Literal.lhs.  Much tidying up in here,
  to bring all the range checking into this one module.

* I got rid of NoRep literals entirely.  They just seem to be too much trouble.

* Because Con's don't exist any more, the funny C { args } syntax
  disappears from inteface files.


Parsing
~~~~~~~
* Result type signatures now work
	f :: Int -> Int = \x -> x
	-- The Int->Int is the type of f

	g x y :: Int = x+y
	-- The Int is the type of the result of (g x y)


Recompilation checking and make
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* The .hi file for a modules is not touched if it doesn't change.  (It used to
  be touched regardless, forcing a chain of recompilations.)  The penalty for this
  is that we record exported things just as if they were mentioned in the body of
  the module.  And the penalty for that is that we may recompile a module when
  the only things that have changed are the things it is passing on without using.
  But it seems like a good trade.

* -recomp is on by default

Foreign declarations
~~~~~~~~~~~~~~~~~~~~
* If you say
	foreign export zoo :: Int -> IO Int
  then you get a C produre called 'zoo', not 'zzoo' as before.
  I've also added a check that complains if you export (or import) a C
  procedure whose name isn't legal C.


Code generation and labels
~~~~~~~~~~~~~~~~~~~~~~~~~~
* Now that constructor workers and wrappers have distinct names, there's
  no need to have a Foo_static_closure and a Foo_closure for constructor Foo.
  I nuked the entire StaticClosure story.  This has effects in some of
  the RTS headers (i.e. s/static_closure/closure/g)


Rules, constant folding
~~~~~~~~~~~~~~~~~~~~~~~
* Constant folding becomes just another rewrite rule, attached to the Id for the
  PrimOp.   To achieve this, there's a new form of Rule, a BuiltinRule (see CoreSyn.lhs).
  The prelude rules are in prelude/PrelRules.lhs, while simplCore/ConFold.lhs has gone.

* Appending of constant strings now works, using fold/build fusion, plus
  the rewrite rule
	unpack "foo" c (unpack "baz" c n)  =  unpack "foobaz" c n
  Implemented in PrelRules.lhs

* The CCall primop is tidied up quite a bit.  There is now a data type CCall,
  defined in PrimOp, that packages up the info needed for a particular CCall.
  There is a new Id for each new ccall, with an big "occurrence name"
	{__ccall "foo" gc Int# -> Int#}
  In interface files, this is parsed as a single Id, which is what it is, really.

Miscellaneous
~~~~~~~~~~~~~
* There were numerous places where the host compiler's
  minInt/maxInt was being used as the target machine's minInt/maxInt.
  I nuked all of these; everything is localised to inIntRange and inWordRange,
  in Literal.lhs

* Desugaring record updates was broken: it didn't generate correct matches when
  used withe records with fancy unboxing etc.  It now uses matchWrapper.

* Significant tidying up in codeGen/SMRep.lhs

* Add __word, __word64, __int64 terminals to signal the obvious types
  in interface files.  Add the ability to print word values in hex into
  C code.

* PrimOp.lhs is no longer part of a loop.  Remove PrimOp.hi-boot*


Types
~~~~~
* isProductTyCon no longer returns False for recursive products, nor
  for unboxed products; you have to test for these separately.
  There's no reason not to do CPR for recursive product types, for example.
  Ditto splitProductType_maybe.

Simplification
~~~~~~~~~~~~~~~
* New -fno-case-of-case flag for the simplifier.  We use this in the first run
  of the simplifier, where it helps to stop messing up expressions that
  the (subsequent) full laziness pass would otherwise find float out.
  It's much more effective than previous half-baked hacks in inlining.

  Actually, it turned out that there were three places in Simplify.lhs that
  needed to know use this flag.

* Make the float-in pass push duplicatable bindings into the branches of
  a case expression, in the hope that we never have to allocate them.
  (see FloatIn.sepBindsByDropPoint)

* Arrange that top-level bottoming Ids get a NOINLINE pragma
  This reduced gratuitous inlining of error messages.
  But arrange that such things still get w/w'd.

* Arrange that a strict argument position is regarded as an 'interesting'
  context, so that if we see
	foldr k z (g x)
  then we'll be inclined to inline g; this can expose a build.

* There was a missing case in CoreUtils.exprEtaExpandArity that meant
  we were missing some obvious cases for eta expansion
  Also improve the code when handling applications.

* Make record selectors (identifiable by their IdFlavour) into "cheap" operations.
	  [The change is a 2-liner in CoreUtils.exprIsCheap]
  This means that record selection may be inlined into function bodies, which
  greatly improves the arities of overloaded functions.

* Make a cleaner job of inlining "lone variables".  There was some distributed
  cunning, but I've centralised it all now in SimplUtils.analyseCont, which
  analyses the context of a call to decide whether it is "interesting".

* Don't specialise very small functions in Specialise.specDefn
  It's better to inline it.  Rather like the worker/wrapper case.

* Be just a little more aggressive when floating out of let rhss.
  See comments with Simplify.wantToExpose
  A small change with an occasional big effect.

* Make the inline-size computation think that
	case x of I# x -> ...
  is *free*.


CPR analysis
~~~~~~~~~~~~
* Fix what was essentially a bug in CPR analysis.  Consider

	letrec f x = let g y = let ... in f e1
		     in
		     if ... then (a,b) else g x

  g has the CPR property if f does; so when generating the final annotated
  RHS for f, we must use an envt in which f is bound to its final abstract
  value.  This wasn't happening.  Instead, f was given the CPR tag but g
  wasn't; but of course the w/w pass gives rotten results in that case!!
  (Because f's CPR-ness relied on g's.)

  On they way I tidied up the code in CprAnalyse.  It's quite a bit shorter.

  The fact that some data constructors return a constructed product shows
  up in their CPR info (MkId.mkDataConId) not in CprAnalyse.lhs



Strictness analysis and worker/wrapper
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* BIG THING: pass in the demand to StrictAnal.saExpr.  This affects situations
  like
	f (let x = e1 in (x,x))
  where f turns out to have strictness u(SS), say.  In this case we can
  mark x as demanded, and use a case expression for it.

  The situation before is that we didn't "know" that there is the u(SS)
  demand on the argument, so we simply computed that the body of the let
  expression is lazy in x, and marked x as lazily-demanded.  Then even after
  f was w/w'd we got

	let x = e1 in case (x,x) of (a,b) -> $wf a b

  and hence

	let x = e1 in $wf a b

  I found a much more complicated situation in spectral/sphere/Main.shade,
  which improved quite a bit with this change.

* Moved the StrictnessInfo type from IdInfo to Demand.  It's the logical
  place for it, and helps avoid module loops

* Do worker/wrapper for coerces even if the arity is zero.  Thus:
	stdout = coerce Handle (..blurg..)
  ==>
	wibble = (...blurg...)
	stdout = coerce Handle wibble
  This is good because I found places where we were saying
	case coerce t stdout of { MVar a ->
	...
	case coerce t stdout of { MVar b ->
	...
  and the redundant case wasn't getting eliminated because of the coerce.
parent 290e7896
......@@ -18,20 +18,27 @@ then
then
Type (loop DataCon.DataCon, loop Subst.substTy)
then
DataCon, TysPrim, Unify, PprType
TysPrim (Type), PprEnv (loop DataCon.DataCon, Type)
then
Unify, PprType (PprEnv)
then
Literal (TysPrim, PprType), DataCon
then
InstEnv (Unify)
then
IdInfo (loop CoreRules.CoreRules)
TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId)
then
PrimOp (PprType, TysWiredIn, IdInfo.StrictnessInfo)
PrimOp (PprType, TysWiredIn)
then
IdInfo (loop CoreSyn.CoreRules, loop CoreUnfold.Unfolding)
then
Const (PrimOp.PrimOp, TysWiredIn.stringTy)
then
Id (Const.Con(..)), CoreSyn
then
CoreUtils (loop PprCore.pprCoreExpr), CoreFVs
CoreFVs, PprCore
then
CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars)
then
OccurAnal (ThinAir.noRepStrs -- an awkward dependency)
then
......
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.71 2000/02/14 11:59:27 sewardj Exp $
# $Id: Makefile,v 1.72 2000/03/23 17:45:17 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -44,6 +44,10 @@ ifeq ($(GhcWithNativeCodeGen),YES)
DIRS += nativeGen
else
SRC_HC_OPTS += -DOMIT_NATIVE_CODEGEN
ifeq ($(GhcWithIlx),YES)
DIRS += ilxGen
SRC_HC_OPTS += -DILX
endif
endif
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.28 2000/03/16 12:37:06 simonmar Exp $
% $Id: AbsCSyn.lhs,v 1.29 2000/03/23 17:45:17 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......@@ -39,17 +39,13 @@ module AbsCSyn {- (
import {-# SOURCE #-} ClosureInfo ( ClosureInfo )
#if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
#endif
import CLabel
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, spRelToInt )
import CostCentre ( CostCentre, CostCentreStack )
import Const ( mkMachInt, Literal(..) )
import Literal ( mkMachInt, Literal(..) )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp )
import PrimOp ( PrimOp, CCall )
import Unique ( Unique )
import StgSyn ( SRT(..) )
import TyCon ( TyCon )
......@@ -167,7 +163,7 @@ stored in a mixed type location.)
compiling 'foreign import dynamic's)
-}
| CCallTypedef Bool {- True => use "typedef"; False => use "extern"-}
PrimOp{-CCallOp-} [CAddrMode] [CAddrMode]
CCall [CAddrMode] [CAddrMode]
-- *** the next three [or so...] are DATA (those above are CODE) ***
......
......@@ -22,14 +22,14 @@ module AbsCUtils (
import AbsCSyn
import Digraph ( stronglyConnComp, SCC(..) )
import DataCon ( fIRST_TAG, ConTag )
import Const ( literalPrimRep, mkMachWord )
import Literal ( literalPrimRep, mkMachWord )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_ProduceC, opt_EmitCExternDecls )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
import Panic ( panic )
infixr 9 `thenFlt`
......@@ -329,17 +329,16 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results td@(CCallOp _ _ _ _) args vol_regs)
flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs)
| isCandidate && maybeToBool opt_ProduceC
= returnFlt (stmt, tdef)
where
(isCandidate, isDyn) =
case td of
CCallOp (Right _) _ _ _ -> (True, True)
CCallOp (Left _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
_ -> (False, False)
case ccall of
CCall (DynamicTarget _) _ _ _ -> (True, True)
CCall (StaticTarget _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
tdef = CCallTypedef isDyn td results args
tdef = CCallTypedef isDyn ccall results args
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.31 2000/03/16 12:37:06 simonmar Exp $
% $Id: CLabel.lhs,v 1.32 2000/03/23 17:45:17 simonpj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......@@ -18,7 +18,6 @@ module CLabel (
mkStaticConEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkApEntryLabel,
mkApInfoTableLabel,
......@@ -143,9 +142,6 @@ data IdLabelInfo
data DataConLabelInfo
= ConEntry -- the only kind of entry pt for constructors
| ConInfoTbl -- corresponding info table
| StaticClosure -- Static constructor closure
-- e.g., nullary constructor
| StaticConEntry -- static constructor entry point
| StaticInfoTbl -- corresponding info table
deriving (Eq, Ord)
......@@ -201,7 +197,6 @@ mkFastEntryLabel id arity = ASSERT(arity > 0)
mkRednCountsLabel id = IdLabel id RednCounts
mkStaticClosureLabel con = DataConLabel con StaticClosure
mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl
mkConInfoTableLabel con = DataConLabel con ConInfoTbl
mkConEntryLabel con = DataConLabel con ConEntry
......@@ -328,7 +323,6 @@ labelType (DataConLabel _ info) =
case info of
ConInfoTbl -> InfoTblType
StaticInfoTbl -> InfoTblType
StaticClosure -> ClosureType
_ -> CodeType
labelType _ = DataType
......@@ -379,7 +373,6 @@ internal names. <type> is one of the following:
dflt Default case alternative
btm Large bitmap vector
closure Static closure
static_closure Static closure (???)
con_entry Dynamic Constructor entry code
con_info Dynamic Constructor info table
static_entry Static Constructor entry code
......@@ -492,7 +485,6 @@ ppIdFlavor x = pp_cSEP <>
ppConFlavor x = pp_cSEP <>
(case x of
StaticClosure -> ptext SLIT("static_closure")
ConEntry -> ptext SLIT("con_entry")
ConInfoTbl -> ptext SLIT("con_info")
StaticConEntry -> ptext SLIT("static_entry")
......
......@@ -2,6 +2,7 @@ This module deals with printing C string literals
\begin{code}
module CStrings(
CLabelString, isCLabelString,
cSEP, pp_cSEP,
stringToC, charToC, pprFSInCStyle,
......@@ -10,23 +11,33 @@ module CStrings(
#include "HsVersions.h"
import Char ( ord, chr )
import Char ( ord, chr, isAlphaNum )
import Outputable
\end{code}
\begin{code}
type CLabelString = FAST_STRING -- A C label, completely unencoded
isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
isCLabelString lbl
= all ok (_UNPK_ lbl)
where
ok c = isAlphaNum c || c == '_' || c == '.'
-- The '.' appears in e.g. "foo.so" in the
-- module part of a ExtName. Maybe it should be separate
cSEP = SLIT("_") -- official C separator
pp_cSEP = char '_'
\end{code}
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
\begin{code}
pprFSInCStyle :: FAST_STRING -> SDoc
pprFSInCStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs)))
-- stringToC: the hassle is what to do w/ strings like "ESC 0"...
stringToC :: String -> String
-- Convert a string to the form required by C in a C literal string
-- Tthe hassle is what to do w/ strings like "ESC 0"...
stringToC "" = ""
stringToC [c] = charToC c
stringToC (c:cs)
......@@ -45,6 +56,8 @@ stringToC (c:cs)
| c == '\v' = "\\v"
| otherwise = '\\' : (octify (ord c))
charToC :: Char -> String
-- Convert a character to the form reqd in a C character literal
charToC c = if (c >= ' ' && c <= '~') -- non-portable...
then case c of
'\'' -> "\\'"
......@@ -60,8 +73,8 @@ charToC c = if (c >= ' ' && c <= '~') -- non-portable...
_ -> [c]
else '\\' : (octify (ord c))
-- really: charToSimpleHaskell
charToEasyHaskell :: Char -> String
-- Convert a character to the form reqd in a Haskell character literal
charToEasyHaskell c
= if (c >= 'a' && c <= 'z')
|| (c >= 'A' && c <= 'Z')
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: Costs.lhs,v 1.20 2000/01/13 14:33:57 hwloidl Exp $
% $Id: Costs.lhs,v 1.21 2000/03/23 17:45:17 simonpj Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
......@@ -390,7 +390,7 @@ primOpCosts :: PrimOp -> CostRes
-- Special cases
primOpCosts (CCallOp _ _ _ _) = SAVE_COSTS + RESTORE_COSTS
primOpCosts (CCallOp _) = SAVE_COSTS + RESTORE_COSTS
-- don't guess costs of ccall proper
-- for exact costing use a GRAN_EXEC
-- in the C code
......@@ -455,124 +455,3 @@ costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
\end{code}
This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
I include here some comments about the estimated costs for these @PrimOps@.
Compare with the @primOpCosts@ fct above. -- HWL
\begin{pseudocode}
data PrimOp
-- I assume all these basic comparisons take just one ALU instruction
-- Checked that for Char, Int; Word, Addr should be the same as Int.
= CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp
| IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp
| WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp
| AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp
-- Analogously, these take one FP unit instruction
-- Haven't checked that, yet.
| FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp
| DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
-- 1 ALU op; unchecked
| OrdOp | ChrOp
-- these just take 1 ALU op; checked
| IntAddOp | IntSubOp
-- but these take more than that; see special cases in primOpCosts
-- I counted the generated ass. instructions for these -> checked
| IntMulOp | IntQuotOp
| IntRemOp | IntNegOp
-- Rest is unchecked so far -- HWL
-- Word#-related ops:
| AndOp | OrOp | NotOp | XorOp | ShiftLOp | ShiftROp
| Int2WordOp | Word2IntOp -- casts
-- Addr#-related ops:
| Int2AddrOp | Addr2IntOp -- casts
-- Float#-related ops:
| FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
| Float2IntOp | Int2FloatOp
| FloatExpOp | FloatLogOp | FloatSqrtOp
| FloatSinOp | FloatCosOp | FloatTanOp
| FloatAsinOp | FloatAcosOp | FloatAtanOp
| FloatSinhOp | FloatCoshOp | FloatTanhOp
-- not all machines have these available conveniently:
-- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp
| FloatPowerOp -- ** op
-- Double#-related ops:
| DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp
| Double2IntOp | Int2DoubleOp
| Double2FloatOp | Float2DoubleOp
| DoubleExpOp | DoubleLogOp | DoubleSqrtOp
| DoubleSinOp | DoubleCosOp | DoubleTanOp
| DoubleAsinOp | DoubleAcosOp | DoubleAtanOp
| DoubleSinhOp | DoubleCoshOp | DoubleTanhOp
-- not all machines have these available conveniently:
-- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp
| DoublePowerOp -- ** op
-- Integer (and related...) ops:
-- slightly weird -- to match GMP package.
| IntegerAddOp | IntegerSubOp | IntegerMulOp
| IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
| IntegerCmpOp
| Integer2IntOp | Int2IntegerOp
| Addr2IntegerOp -- "Addr" is *always* a literal string
-- ?? gcd, etc?
| FloatEncodeOp | FloatDecodeOp
| DoubleEncodeOp | DoubleDecodeOp
-- primitive ops for primitive arrays
| NewArrayOp
| NewByteArrayOp PrimRep
| SameMutableArrayOp
| SameMutableByteArrayOp
| ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
| ReadByteArrayOp PrimRep
| WriteByteArrayOp PrimRep
| IndexByteArrayOp PrimRep
| IndexOffAddrOp PrimRep
-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
-- Note that ForeignObjRep is not included -- the only way of
-- creating a ForeignObj is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
| MakeStablePtrOp | DeRefStablePtrOp
\end{pseudocode}
A special ``trap-door'' to use in making calls direct to C functions:
Note: From GrAn point of view, CCall is probably very expensive
The programmer can specify the costs of the Ccall by inserting
a GRAN_EXEC(a,b,l,s,f) at the end of the C- code, specifing the
number or arithm., branch, load, store and floating point instructions
-- HWL
\begin{pseudocode}
| CCallOp String -- An "unboxed" ccall# to this named function
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
[Type] -- Unboxed argument; the state-token
-- argument will have been put *first*
Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{pseudocode}
......@@ -26,11 +26,11 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
)
import Constants ( mIN_UPD_SIZE )
import CallConv ( CallConv, callConvAttribute, cCallConv )
import CallConv ( CallConv, callConvAttribute )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
mkStaticClosureLabel,
mkClosureLabel,
CLabel, CLabelType(..), labelType, labelDynamic
)
......@@ -40,12 +40,12 @@ import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Const ( Literal(..) )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-} )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
......@@ -176,8 +176,8 @@ pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
do_if_stmt discrim tag alt_code dc c
-- What problem is the re-ordering trying to solve ?
pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
(tag2@(MachInt i2 _), alt_code2)] deflt) c
pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
(tag2@(MachInt i2), alt_code2)] deflt) c
| empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
= if (i1 == 0) then
do_if_stmt discrim tag1 alt_code1 alt_code2 c
......@@ -213,8 +213,8 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case
-- Costs for addressing header of switch and cond. branching -- HWL
switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
= pprCCall op args results vol_regs
pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
= pprCCall ccall args results vol_regs
pprAbsC stmt@(COpStmt results op args vol_regs) _
= let
......@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef op@(CCallOp op_str is_asm may_gc cconv) results args) _
pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
......@@ -327,8 +327,8 @@ pprAbsC stmt@(CCallTypedef is_tdef op@(CCallOp op_str is_asm may_gc cconv) resul
ccall_fun_ty =
case op_str of
Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
Left x -> ptext x
DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
StaticTarget x -> ptext x
ccall_res_ty =
case non_void_results of
......@@ -505,7 +505,7 @@ pprAbsC stmt@(CClosureTbl tycon) _
ptext SLIT("CLOSURE_TBL") <>
lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
punctuate comma (
map (pp_closure_lbl . mkStaticClosureLabel . getName) (tyConDataCons tycon)
map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
)
) $$ ptext SLIT("};")
......@@ -637,18 +637,13 @@ ppr_vol_regs (r:rs)
(($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
-- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- depending on the platform. (The "volatile regs" stuff handles all
-- other registers.) Just be *sure* BaseReg is OK before trying to do
-- anything else. The correct sequence of saves&restores are
-- encoded by the CALLER_*_SYSTEM macros.
pp_basic_saves
= vcat
[ ptext SLIT("CALLER_SAVE_Base")
, ptext SLIT("CALLER_SAVE_SYSTEM")
]
pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM")
pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
\end{code}
......@@ -690,10 +685,10 @@ do_if_stmt discrim tag alt_code deflt c
= case tag of
-- This special case happens when testing the result of a comparison.
-- We can just avoid some redundant clutter in the output.
MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
deflt alt_code
(addrModeCosts discrim Rhs) c
other -> let
other -> let
cond = hcat [ pprAmode discrim
, ptext SLIT(" == ")
, tcast
......@@ -707,10 +702,9 @@ do_if_stmt discrim tag alt_code deflt c
-- in C (when minInt is a number not a constant
-- expression which evaluates to it.)
--
tcast =
case other of
MachInt _ signed | signed -> ptext SLIT("(I_)")
_ -> empty
tcast = case other of
MachInt _ -> ptext SLIT("(I_)")
_ -> empty
in
ppr_if_stmt cond
alt_code deflt
......@@ -783,7 +777,7 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
......@@ -829,17 +823,17 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
ccall_fun_ty =
ptext SLIT("_ccall_fun_ty") <>
case op_str of
Right u -> ppr u
_ -> empty
DynamicTarget u -> ppr u
_ -> empty
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
(Left asm_str) = op_str
(StaticTarget asm_str) = op_str
is_dynamic =
case op_str of
Left _ -> False
_ -> True
StaticTarget _ -> False
DynamicTarget _ -> True
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
......@@ -1201,9 +1195,9 @@ pp_liveness :: Liveness -> SDoc
pp_liveness lv =
case lv of
LvLarge lbl -> char '&' <> pprCLabel lbl
LvSmall mask
| bitmap_int == (minBound :: Int) -> int (bitmap_int+1) <> text "-1"
| otherwise -> int bitmap_int
LvSmall mask -- Avoid gcc bug when printing minInt
| bitmap_int == minInt -> int (bitmap_int+1) <> text "-1"
| otherwise -> int bitmap_int
where
bitmap_int = intBS mask
\end{code}
......@@ -1621,7 +1615,7 @@ floatToWord (CLit (MachFloat r))
arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 (fromRational r)
i <- readIntArray arr 0
return (CLit (MachInt (toInteger i) True))
return (CLit (MachInt (toInteger i)))
)
doubleToWords :: CAddrMode -> [CAddrMode]
......@@ -1632,8 +1626,8 @@ doubleToWords (CLit (MachDouble r))
writeDoubleArray arr 0 (fromRational r)
i1 <- readIntArray arr 0
i2 <- readIntArray arr 1
return [ CLit (MachInt (toInteger i1) True)
, CLit (MachInt (toInteger i2) True)
return [ CLit (MachInt (toInteger i1))
, CLit (MachInt (toInteger i2))
]
)
| otherwise -- doubles are 1 word
......@@ -1641,6 +1635,6 @@ doubleToWords (CLit (MachDouble r))
arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
i <- readIntArray arr 0
return [ CLit (MachInt (toInteger i) True) ]
return [ CLit (MachInt (toInteger i)) ]
)
\end{code}
......@@ -14,13 +14,25 @@ types that
\begin{code}
module BasicTypes(
Version, Arity,
Version,
Arity,
Unused, unused,
Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, negateFixity, negatePrecedence,
NewOrData(..),
RecFlag(..), isRec, isNonRec,
TopLevelFlag(..), isTopLevel, isNotTopLevel
TopLevelFlag(..), isTopLevel, isNotTopLevel,
OccInfo(..), seqOccInfo, isFragileOccInfo,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch
) where
#include "HsVersions.h"
......@@ -151,3 +163,64 @@ isNonRec :: RecFlag -> Bool
isNonRec Recursive = False
isNonRec NonRecursive = True
\end{code}
%************************************************************************
%* *
\subsection{Occurrence information}
%* *
%************************************************************************
This data type is used exclusively by the simplifier, but it appears in a
SubstResult, which is currently defined in VarEnv, which is pretty near
the base of the module hierarchy. So it seemed simpler to put the
defn of OccInfo here, safely at the bottom
\begin{code}
data OccInfo
= NoOccInfo
| IAmDead -- Marks unused variables. Sometimes useful for