Commit b4797136 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 65e41952 c23faf30
......@@ -245,6 +245,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
osf3)
test -z "[$]2" || eval "[$]2=OSOsf3"
;;
nto-qnx)
test -z "[$]2" || eval "[$]2=OSQNXNTO"
;;
dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
......@@ -1830,6 +1833,9 @@ case "$1" in
# i686-gentoo-freebsd8.2
$2="freebsd"
;;
nto-qnx*)
$2="nto-qnx"
;;
*)
echo "Unknown OS $1"
exit 1
......
......@@ -9,7 +9,31 @@ module CmmInfo (
mkEmptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
srtEscape
srtEscape,
-- info table accessors
closureInfoPtr,
entryCode,
getConstrTag,
cmmGetClosureType,
infoTable,
infoTableConstrTag,
infoTableSrtBitmap,
infoTableClosureType,
infoTablePtrs,
infoTableNonPtrs,
funInfoTable,
-- info table sizes and offsets
stdInfoTableSizeW,
fixedInfoTableSizeW,
profInfoTableSizeW,
maxStdInfoTableSizeW,
maxRetInfoTableSizeW,
stdInfoTableSizeB,
stdSrtBitmapOffset,
stdClosureTypeOffset,
stdPtrsOffset, stdNonPtrsOffset,
) where
#include "HsVersions.h"
......@@ -388,3 +412,132 @@ newStringLit bytes
-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags = toStgHalfWord dflags (-1)
-------------------------------------------------------------------------
--
-- Accessing fields of an info table
--
-------------------------------------------------------------------------
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr dflags e = CmmLoad e (bWord dflags)
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode dflags e
| tablesNextToCode dflags = e
| otherwise = CmmLoad e (bWord dflags)
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable dflags info_ptr
| tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
| otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
-- and returns a pointer to the first word of the StgFunInfoExtra struct
-- in the info table.
funInfoTable dflags info_ptr
| tablesNextToCode dflags
= cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-- Past the entry code pointer
-----------------------------------------------------------------------------
--
-- Info table sizes & offsets
--
-----------------------------------------------------------------------------
stdInfoTableSizeW :: DynFlags -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
-- It must vary in sync with mkStdInfoTable
stdInfoTableSizeW dflags
= fixedInfoTableSizeW
+ if gopt Opt_SccProfilingOn dflags
then profInfoTableSizeW
else 0
fixedInfoTableSizeW :: WordOff
fixedInfoTableSizeW = 2 -- layout, type
profInfoTableSizeW :: WordOff
profInfoTableSizeW = 2
maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW =
1 {- entry, when !tablesNextToCode -}
+ fixedInfoTableSizeW
+ profInfoTableSizeW
maxRetInfoTableSizeW :: WordOff
maxRetInfoTableSizeW =
maxStdInfoTableSizeW
+ 1 {- srt label -}
stdInfoTableSizeB :: DynFlags -> ByteOff
stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
......@@ -5,9 +5,9 @@ module CmmLayoutStack (
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
import StgCmmLayout ( entryCode ) -- XXX layering violation
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
......
......@@ -186,6 +186,7 @@ import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame )
import MkGraph
import Cmm
import CmmUtils
import CmmInfo
import BlockId
import CmmLex
import CLabel
......
......@@ -32,6 +32,7 @@ import MkGraph
import CoreSyn ( AltCon(..) )
import SMRep
import Cmm
import CmmInfo
import CmmUtils
import CLabel
import StgSyn
......
......@@ -30,6 +30,7 @@ import StgSyn
import MkGraph
import BlockId
import Cmm
import CmmInfo
import CoreSyn
import DataCon
import ForeignCall
......
......@@ -24,14 +24,6 @@ module StgCmmLayout (
mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel,
stdInfoTableSizeB,
entryCode, closureInfoPtr,
getConstrTag,
cmmGetClosureType,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable,
ArgRep(..), toArgRep, argRepSizeW
) where
......@@ -49,6 +41,7 @@ import MkGraph
import SMRep
import Cmm
import CmmUtils
import CmmInfo
import CLabel
import StgSyn
import Id
......@@ -534,116 +527,3 @@ emitClosureAndInfoTable info_tbl conv args body
; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
}
-----------------------------------------------------------------------------
--
-- Info table offsets
--
-----------------------------------------------------------------------------
stdInfoTableSizeW :: DynFlags -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
-- It must vary in sync with mkStdInfoTable
stdInfoTableSizeW dflags
= size_fixed + size_prof
where
size_fixed = 2 -- layout, type
size_prof | gopt Opt_SccProfilingOn dflags = 2
| otherwise = 0
stdInfoTableSizeB :: DynFlags -> ByteOff
stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
-------------------------------------------------------------------------
--
-- Accessing fields of an info table
--
-------------------------------------------------------------------------
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr dflags e = CmmLoad e (bWord dflags)
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode dflags e
| tablesNextToCode dflags = e
| otherwise = CmmLoad e (bWord dflags)
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable dflags info_ptr
| tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
| otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
-- and returns a pointer to the first word of the StgFunInfoExtra struct
-- in the info table.
funInfoTable dflags info_ptr
| tablesNextToCode dflags
= cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-- Past the entry code pointer
......@@ -29,6 +29,7 @@ import BasicTypes
import MkGraph
import StgSyn
import Cmm
import CmmInfo
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
......
......@@ -2,7 +2,7 @@ module DebuggerUtils (
dataConInfoPtrToName,
) where
import StgCmmLayout ( stdInfoTableSizeB )
import CmmInfo ( stdInfoTableSizeB )
import ByteCodeItbls
import DynFlags
import FastString
......
......@@ -31,8 +31,7 @@ import UniqSupply
import Unique
import Util
import Data.List ( partition )
import Data.List ( partition )
type LlvmStatements = OrdList LlvmStatement
......@@ -706,6 +705,7 @@ genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
genCondBranch env cond idT idF = do
let labelT = blockIdToLlvm idT
let labelF = blockIdToLlvm idF
-- See Note [Literals and branch conditions].
(env', vc, stmts, top) <- exprToVarOpt env i1Option cond
if getVarType vc == i1
then do
......@@ -714,6 +714,57 @@ genCondBranch env cond idT idF = do
else
panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
{- Note [Literals and branch conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is important that whenever we generate branch conditions for
literals like '1', they are properly narrowed to an LLVM expression of
type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
must be certain to return a properly narrowed type. genLit is
responsible for this, in the case of literal integers.
Often, we won't see direct statements like:
if(1) {
...
} else {
...
}
at this point in the pipeline, because the Glorious Code Generator
will do trivial branch elimination in the sinking pass (among others,)
which will eliminate the expression entirely.
However, it's certainly possible and reasonable for this to occur in
hand-written C-- code. Consider something like:
#ifndef SOME_CONDITIONAL
#define CHECK_THING(x) 1
#else
#define CHECK_THING(x) some_operation((x))
#endif
f() {
if (CHECK_THING(xyz)) {
...
} else {
...
}
}
In such an instance, CHECK_THING might result in an *expression* in
one case, and a *literal* in the other, depending on what in
particular was #define'd. So we must be sure to properly narrow the
literal in this case to i1 as it won't be eliminated beforehand.
For a real example of this, see ./rts/StgStdThunks.cmm
-}
-- | Switch branch
--
......@@ -746,31 +797,30 @@ type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl])
-- | Values which can be passed to 'exprToVar' to configure its
-- behaviour in certain circumstances.
data EOption = EOption {
-- | The expected LlvmType for the returned variable.
--
-- Currently just used for determining if a comparison should return
-- a boolean (i1) or a int (i32/i64).
eoExpectedType :: Maybe LlvmType
}
--
-- Currently just used for determining if a comparison should return
-- a boolean (i1) or a word. See Note [Literals and branch conditions].
newtype EOption = EOption { i1Expected :: Bool }
-- XXX: EOption is an ugly and inefficient solution to this problem.
-- | i1 type expected (condition scrutinee).
i1Option :: EOption
i1Option = EOption (Just i1)
wordOption :: DynFlags -> EOption
wordOption dflags = EOption (Just (llvmWord dflags))
i1Option = EOption True
-- | Word type expected (usual).
wordOption :: EOption
wordOption = EOption False
-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar.
exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
exprToVar env = exprToVarOpt env (wordOption (getDflags env))
exprToVar env = exprToVarOpt env wordOption
exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
exprToVarOpt env opt e = case e of
CmmLit lit
-> genLit env lit
-> genLit opt env lit
CmmLoad e' ty
-> genLoad env e' ty
......@@ -1020,26 +1070,16 @@ genMachOp_slow env opt op [x, y] = case op of
-- | Need to use EOption here as Cmm expects word size results from
-- comparisons while LLVM return i1. Need to extend to llvmWord type
-- if expected
-- if expected. See Note [Literals and branch conditions].
genBinComp opt cmp = do
ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
if getVarType v1 == i1
then
case eoExpectedType opt of
Nothing ->
return ed
Just t | t == i1 ->
return ed
| isInt t -> do
(v2, s1) <- doExpr t $ Cast LM_Zext v1 t
return (env', v2, stmts `snocOL` s1, top)
| otherwise ->
panic $ "genBinComp: Can't case i1 compare"
++ "res to non int type " ++ show (t)
then case i1Expected opt of
True -> return ed
False -> do
let w_ = llvmWord dflags
(v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
return (env', v2, stmts `snocOL` s1, top)
else
panic $ "genBinComp: Compare returned type other then i1! "
++ (show $ getVarType v1)
......@@ -1206,15 +1246,22 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
-- | Generate code for a literal
genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
genLit env (CmmInt i w)
= return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
genLit env (CmmFloat r w)
genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData
genLit opt env (CmmInt i w)
-- See Note [Literals and branch conditions].
= let width | i1Expected opt = i1
| otherwise = LMInt (widthInBits w)
-- comm = Comment [ fsLit $ "EOption: " ++ show opt
-- , fsLit $ "Width : " ++ show w
-- , fsLit $ "Width' : " ++ show (widthInBits w)
-- ]
in return (env, mkIntLit width i, nilOL, [])
genLit _ env (CmmFloat r w)
= return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
nilOL, [])
genLit env cmm@(CmmLabel l)
genLit _ env cmm@(CmmLabel l)
= let dflags = getDflags env
label = strCLabel_llvm env l
ty = funLookup label env
......@@ -1236,17 +1283,17 @@ genLit env cmm@(CmmLabel l)
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
return (env, v1, unitOL s1, [])
genLit env (CmmLabelOff label off) = do
genLit opt env (CmmLabelOff label off) = do
let dflags = getDflags env
(env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
(env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label)
let voff = toIWord dflags off
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
return (env', v1, stmts `snocOL` s1, stat)
genLit env (CmmLabelDiffOff l1 l2 off) = do
genLit opt env (CmmLabelDiffOff l1 l2 off) = do
let dflags = getDflags env
(env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
(env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
(env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1)
(env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2)
let voff = toIWord dflags off
let ty1 = getVarType vl1
let ty2 = getVarType vl2
......@@ -1262,10 +1309,10 @@ genLit env (CmmLabelDiffOff l1 l2 off) = do
else
panic "genLit: CmmLabelDiffOff encountered with different label ty!"
genLit env (CmmBlock b)
= genLit env (CmmLabel $ infoTblLbl b)
genLit opt env (CmmBlock b)
= genLit opt env (CmmLabel $ infoTblLbl b)
genLit _ CmmHighStackMark
genLit _ _ CmmHighStackMark
= panic "genStaticLit - CmmHighStackMark unsupported!"
......
......@@ -1232,18 +1232,18 @@ runPhase As input_fn dflags
let whichAsProg | hscTarget dflags == HscLlvm &&
platformOS (targetPlatform dflags) == OSDarwin
= do
-- be careful what options we call clang with
-- see #5903 and #7617 for bugs caused by this.
llvmVer <- liftIO $ figureLlvmVersion dflags
return $ case llvmVer of
Just n | n >= 30 ->
(SysTools.runClang, getOpts dflags opt_c)
Just n | n >= 30 -> SysTools.runClang
_ -> SysTools.runAs