Commit 13602a46 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents 07a27407 b8e00747
......@@ -46,18 +46,9 @@ name :: IORef (ty); \
name = Util.globalM (value);
#endif
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
#else
-- We have to actually use all the variables we are given or we may get
-- unused variable warnings when DEBUG is off.
#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else
#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else
#define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else
-- Here we deliberately don't use when as Control.Monad might not be imported
#endif
-- Examples: Assuming flagSet :: String -> m Bool
--
......
......@@ -26,7 +26,7 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
Arity,
Arity, RepArity,
Alignment,
......@@ -101,7 +101,18 @@ import Data.Function (on)
%************************************************************************
\begin{code}
-- | The number of value arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has arity 0
-- \x -> fib x has arity 1
type Arity = Int
-- | The number of represented arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has representation arity 0
-- \x -> fib x has representation arity 1
-- \(# x, y #) -> fib (x + y) has representation arity 2
type RepArity = Int
\end{code}
%************************************************************************
......
......@@ -31,7 +31,7 @@ module DataCon (
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
......@@ -692,9 +692,14 @@ dataConSourceArity dc = length (dcOrigArgTys dc)
-- | Gives the number of actual fields in the /representation/ of the
-- data constructor. This may be more than appear in the source code;
-- the extra ones are the existentially quantified dictionaries
dataConRepArity :: DataCon -> Int
dataConRepArity :: DataCon -> Arity
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
-- | The number of fields in the /representation/ of the constructor
-- AFTER taking into account the unpacking of any unboxed tuple fields
dataConRepRepArity :: DataCon -> RepArity
dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
-- | Return whether there are any argument types for this 'DataCon's original source type
isNullarySrcDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
......
......@@ -41,8 +41,8 @@ module Id (
mkWorkerId, mkWiredInIdName,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
idPrimRep, recordSelectorFieldLabel,
idName, idType, idUnique, idInfo, idDetails, idRepArity,
recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
......@@ -126,7 +126,7 @@ import Outputable
import Unique
import UniqSupply
import FastString
import Util( count )
import Util
import StaticFlags
-- infixl so you can say (id `set` a `set` b)
......@@ -158,9 +158,6 @@ idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
setIdName :: Id -> Name -> Id
setIdName = Var.setVarName
......@@ -462,6 +459,9 @@ idArity id = arityInfo (idInfo id)
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
idRepArity :: Id -> RepArity
idRepArity x = typeRepArity (idArity x) (idType x)
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
......
......@@ -52,9 +52,7 @@ module Literal
import TysPrim
import PrelNames
import Type
import TypeRep
import TyCon
import Var
import Outputable
import FastTypes
import FastString
......@@ -62,6 +60,8 @@ import BasicTypes
import Binary
import Constants
import UniqFM
import Util
import Data.Int
import Data.Ratio
import Data.Word
......@@ -120,32 +120,27 @@ data Literal
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
| LitInteger Integer Id -- ^ Integer literals
-- See Note [Integer literals]
| LitInteger Integer Type -- ^ Integer literals
-- See Note [Integer literals]
deriving (Data, Typeable)
\end{code}
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
easier to write RULEs for them.
* The Id is for mkInteger, which we use when finally creating the core.
* They only get converted into real Core,
mkInteger [c1, c2, .., cn]
during the CorePrep phase.
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.
* When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id. So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
They only get converted into real Core,
mkInteger [c1, c2, .., cn]
during the CorePrep phase, although TidyPgm looks ahead at what the
core will be, so that it can see whether it involves CAFs.
* When looking for CAF-hood (in TidyPgm), we must take account of the
CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL.
Indeed this is the only reason we put the mk_integer field in the
literal -- otherwise we could just look it up in CorePrep.
When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id. So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
Binary instance
......@@ -203,8 +198,8 @@ instance Binary Literal where
return (MachLabel aj mb fod)
_ -> do
i <- get bh
-- See Note [Integer literals]
return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
-- See Note [Integer literals] in Literal
\end{code}
\begin{code}
......@@ -265,7 +260,7 @@ mkMachChar = MachChar
mkMachString :: String -> Literal
mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
mkLitInteger :: Integer -> Id -> Literal
mkLitInteger :: Integer -> Type -> Literal
mkLitInteger = LitInteger
inIntRange, inWordRange :: Integer -> Bool
......@@ -389,12 +384,7 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
literalType (LitInteger _ mk_integer_id)
-- We really mean idType, rather than varType, but importing Id
-- causes a module import loop
= case varType mk_integer_id of
FunTy _ (FunTy _ integerTy) -> integerTy
_ -> panic "literalType: mkIntegerId has the wrong type"
literalType (LitInteger _ t) = t
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
......
......@@ -503,13 +503,13 @@ mkDictSelId no_unf name clas
-- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
dictSelRule :: Int -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
dictSelRule val_index n_ty_args id_unf args
dictSelRule val_index n_ty_args _ id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (con_args !! val_index)
......@@ -920,12 +920,12 @@ seqId = pcMiscPrelId seqName ty info
, ru_try = match_seq_of_cast
}
match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ _ = Nothing
match_seq_of_cast _ _ _ = Nothing
------------------------------------------------
lazyId :: Id -- See Note [lazyId magic]
......
......@@ -71,6 +71,7 @@ import FastTypes
import FastString
import Outputable
-- import StaticFlags
import Util
#if defined(__GLASGOW_HASKELL__)
--just for implementing a fast [0,61) -> Char function
......
......@@ -32,7 +32,7 @@ import Constants
import Digraph
import qualified Prelude as P
import Prelude hiding (succ)
import Util (sortLe)
import Util
import BlockId
import Bitmap
......
......@@ -27,6 +27,8 @@ import Platform
import StaticFlags
import UniqSupply
import MonadUtils
import Util
import Data.Bits
import Data.Word
......
......@@ -72,7 +72,7 @@ module CmmUtils(
#include "HsVersions.h"
import TyCon ( PrimRep(..) )
import Type ( Type, typePrimRep )
import Type ( UnaryType, typePrimRep )
import SMRep
import Cmm
......@@ -83,6 +83,7 @@ import OptimizationFuel as F
import Unique
import UniqSupply
import Constants( wORD_SIZE, tAG_MASK )
import Util
import Data.Word
import Data.Maybe
......@@ -107,7 +108,7 @@ primRepCmmType AddrRep = bWord
primRepCmmType FloatRep = f32
primRepCmmType DoubleRep = f64
typeCmmType :: Type -> CmmType
typeCmmType :: UnaryType -> CmmType
typeCmmType ty = primRepCmmType (typePrimRep ty)
primRepForeignHint :: PrimRep -> ForeignHint
......@@ -121,7 +122,7 @@ primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
typeForeignHint :: Type -> ForeignHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
---------------------------------------------------
......
......@@ -42,6 +42,7 @@ import SMRep (ByteOff)
import StaticFlags
import Unique
import UniqSupply
import Util
#include "HsVersions.h"
......
......@@ -22,6 +22,7 @@ import Control.Monad
import StaticFlags (opt_Fuel)
import UniqSupply
import Panic
import Util
import Compiler.Hoopl
import Compiler.Hoopl.GHC (getFuel, setFuel)
......
......@@ -411,15 +411,12 @@ getArgAmode (StgLitArg lit)
= do { cmm_lit <- cgLit lit
; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
| isStgTypeArg atom = getArgAmodes atoms
| otherwise = do { amode <- getArgAmode atom
; amodes <- getArgAmodes atoms
; return ( amode : amodes ) }
= do { amode <- getArgAmode atom
; amodes <- getArgAmodes atoms
; return ( amode : amodes ) }
\end{code}
%************************************************************************
......
......@@ -72,7 +72,7 @@ cgTopRhsCon id con args
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT
; amodes <- getArgAmodes args
......@@ -324,7 +324,7 @@ cgReturnDataCon con amodes
-- for it to be marked as "used" for LDV profiling.
| opt_SccProfilingOn = build_it_then enter_it
| otherwise
= ASSERT( amodes `lengthIs` dataConRepArity con )
= ASSERT( amodes `lengthIs` dataConRepRepArity con )
do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
; case sequel of
CaseAlts _ (Just (alts, deflt_lbl)) bndr
......@@ -466,8 +466,8 @@ cgDataCon data_con
; ldvEnter (CmmReg nodeReg)
; body_code }
arg_reps :: [(CgRep, Type)]
arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
arg_reps :: [(CgRep, UnaryType)]
arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
body_code = do {
-- NB: We don't set CC when entering data (WDP 94/06)
......
......@@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples.
newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty =
let
ty_args = tyConAppArgs (repType res_ty)
UbxTupleRep ty_args = repType res_ty
(reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
let rep = typeCgRep ty,
nonVoidArg rep ]
......
......@@ -311,4 +311,5 @@ shimForeignCallArg arg expr
| otherwise = expr
where
-- should be a tycon app, since this is a foreign call
tycon = tyConAppTyCon (repType (stgArgType arg))
UnaryRep rep_ty = repType (stgArgType arg)
tycon = tyConAppTyCon rep_ty
......@@ -77,6 +77,7 @@ import VarEnv
import OrdList
import Unique
import UniqSupply
import Util
import Outputable
import Control.Monad
......
......@@ -43,6 +43,7 @@ import StgSyn
import PrimOp
import Outputable
import StaticFlags
import Util
import Control.Monad
import Data.Maybe
......
......@@ -20,6 +20,8 @@ the STG paper.
-- for details
module ClosureInfo (
idRepArity,
ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
StandardFormInfo(..), -- mkCmmInfo looks inside
SMRep,
......@@ -96,6 +98,7 @@ import Outputable
import FastString
import Constants
import DynFlags
import Util
\end{code}
......@@ -156,7 +159,7 @@ ClosureInfo contains a LambdaFormInfo.
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
!Int -- Arity. Invariant: always > 0
!RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
......@@ -180,7 +183,7 @@ data LambdaFormInfo
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
!Int -- arity;
!RepArity -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
......@@ -211,7 +214,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.
Int -- Arity, n
RepArity -- Arity, n
\end{code}
......@@ -288,7 +291,7 @@ idCgRep x = typeCgRep . idType $ x
tyConCgRep :: TyCon -> CgRep
tyConCgRep = primRepToCgRep . tyConPrimRep
typeCgRep :: Type -> CgRep
typeCgRep :: UnaryType -> CgRep
typeCgRep = primRepToCgRep . typePrimRep
\end{code}
......@@ -384,9 +387,12 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
= case tyConAppTyCon_maybe (repType ty) of
Just tc -> not (isDataTyCon tc)
Nothing -> True
| UnaryRep rep <- repType ty
, Just tc <- tyConAppTyCon_maybe rep
, isDataTyCon tc
= False
| otherwise
= True
\end{code}
@mkConLFInfo@ is similar, for constructors.
......@@ -404,7 +410,7 @@ mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
(might_be_a_function (idType id))
mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
(might_be_a_function (idType id))
......@@ -416,12 +422,12 @@ Miscellaneous LF-infos.
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id = LFUnknown (might_be_a_function (idType id))
mkLFLetNoEscape :: Int -> LambdaFormInfo
mkLFLetNoEscape :: RepArity -> LambdaFormInfo
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idArity id of
= case idRepArity id of
n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
_ -> mkLFArgument id -- Not sure of exact arity
\end{code}
......@@ -634,13 +640,13 @@ data CallMethod
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
RepArity -- Its arity
getCallMethod :: DynFlags
-> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> RepArity -- Number of available arguments
-> CallMethod
getCallMethod _ _ _ lf_info _
......@@ -911,11 +917,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
isConstrClosure_maybe _ = Nothing
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
closureFunInfo _ = Nothing
lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
......@@ -935,7 +941,7 @@ funTagLFInfo lf
| otherwise
= 0
tagForArity :: Int -> Maybe Int
tagForArity :: RepArity -> Maybe Int
tagForArity i | i <= mAX_PTR_TAG = Just i
| otherwise = Nothing
......
......@@ -45,6 +45,7 @@ import TyCon
import Module
import ErrUtils
import Panic
import Util
codeGen :: DynFlags
-> Module -- Module we are compiling
......
......@@ -46,6 +46,7 @@ import TyCon
import Module
import ErrUtils
import Outputable
import Util
codeGen :: DynFlags
-> Module
......@@ -273,8 +274,8 @@ cgDataCon data_con
(tagForCon data_con)] }
-- The case continuation code expects a tagged pointer
arg_reps :: [(PrimRep, Type)]
arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
arg_reps :: [(PrimRep, UnaryType)]
arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
-- Dynamic closure code for non-nullary constructors only
; whenC (not (isNullaryRepDataCon data_con))
......
......@@ -21,8 +21,8 @@ module StgCmmClosure (
DynTag, tagForCon, isSmallFamily,
ConTagZ, dataConTagZ,
isVoidRep, isGcPtrRep, addIdReps, addArgReps,
argPrimRep,
idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
argPrimRep,
-- * LambdaFormInfo
LambdaFormInfo, -- Abstract
......@@ -90,6 +90,7 @@ import Outputable
import Platform
import Constants
import DynFlags
import Util
-----------------------------------------------------------------------------
-- Representations
......@@ -97,6 +98,10 @@ import DynFlags
-- Why are these here?
-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
addIdReps :: [Id] -> [(PrimRep, Id)]
addIdReps ids = [(idPrimRep id, id) | id <- ids]
......@@ -127,7 +132,7 @@ isGcPtrRep _ = False
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
!Int -- Arity. Invariant: always > 0
!RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should really be in ClosureInfo)
......@@ -188,7 +193,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.