...
 
Commits (102)
......@@ -767,6 +767,7 @@ validate-x86_64-linux-fedora27:
.build-windows:
<<: *only-default
allow_failure: true
before_script:
- git clean -xdf
......@@ -815,12 +816,10 @@ validate-x86_64-linux-fedora27:
- |
python boot
bash -c './configure --enable-tarballs-autodownload GHC=`pwd`/toolchain/bin/ghc HAPPY=`pwd`/toolchain/bin/happy ALEX=`pwd`/toolchain/bin/alex'
- bash -c "PATH=`pwd`/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --flavour=Quick --docs=no-sphinx binary-dist"
- bash -c "PATH=`pwd`/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist"
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
- bash -c "export TOP=$(pwd); cd _build/bindist/ghc-*/ && PATH=$TOP/toolchain/bin:$PATH ./configure --prefix=$TOP/_build/install && make install && cd ../../../"
- bash -c "export TOP=$(pwd); PATH=$TOP/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --flavour=quick test --summary-junit=./junit.xml --skip-perf --test-compiler=$TOP/_build/install/bin/ghc"
# skipping perf tests for now since we build a quick-flavoured GHC,
# which might result in some broken perf tests?
- bash -c "export TOP=$(pwd); PATH=$TOP/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` test --summary-junit=./junit.xml --test-compiler=$TOP/_build/install/bin/ghc"
tags:
- x86_64-windows
artifacts:
......@@ -834,6 +833,7 @@ validate-x86_64-linux-fedora27:
validate-x86_64-windows-hadrian:
extends: .build-windows-hadrian
stage: full-build
variables:
MSYSTEM: MINGW64
TEST_ENV: "x86_64-windows-hadrian"
......
......@@ -647,6 +647,7 @@ AC_DEFUN([FP_SET_CFLAGS_C99],
# $5 is the name of the CPP flags variable
AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
[
AC_REQUIRE([FP_PROG_LD_IS_GNU])
AC_MSG_CHECKING([Setting up $2, $3, $4 and $5])
case $$1 in
i386-*)
......@@ -663,10 +664,20 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
$2="$$2 -march=i686"
;;
x86_64-unknown-solaris2)
# Solaris is a multi-lib platform, providing both 32- and 64-bit
# user-land. It appears to default to 32-bit builds but we of course want to
# compile for 64-bits on x86-64.
#
# On OpenSolaris uses gnu ld whereas SmartOS appears to use the Solaris
# implementation, which rather uses the -64 flag.
$2="$$2 -m64"
$3="$$3 -m64"
$4="$$4 -m64"
$5="$$5 -m64"
if test "$fp_cv_gnu_ld" = "yes"; then
$4="$$4 -m64"
else
$4="$$4 -64"
fi
;;
alpha-*)
# For now, to suppress the gcc warning "call-clobbered
......
......@@ -4,8 +4,8 @@
-- (c) The University of Glasgow 2002-2006
--
-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeAsm (
-- | Bytecode assembler and linker
module GHC.ByteCode.Asm (
assembleBCOs, assembleOneBCO,
bcoFreeNames,
......@@ -17,11 +17,11 @@ module ByteCodeAsm (
import GhcPrelude
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi
import GHC.Runtime.Interpreter
import HscTypes
import Name
......@@ -30,7 +30,7 @@ import Literal
import TyCon
import FastString
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import DynFlags
import Outputable
import GHC.Platform
......@@ -55,7 +55,7 @@ import Data.Array.Unsafe( castSTUArray )
import Foreign
import Data.Char ( ord )
import Data.List
import Data.List ( genericLength )
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
......@@ -460,8 +460,8 @@ assembleI dflags i = case i of
LitNumWord -> int (fromIntegral i)
LitNumInt64 -> int64 (fromIntegral i)
LitNumWord64 -> int64 (fromIntegral i)
LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"
LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"
-- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
-- likely to elicit a crash (rather than corrupt memory) in case absence
-- analysis messed up.
......
......@@ -4,15 +4,15 @@
-- (c) The University of Glasgow 2002-2006
--
-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
module ByteCodeItbls ( mkITbls ) where
-- | Generate infotables for interpreter-made bytecodes
module GHC.ByteCode.InfoTable ( mkITbls ) where
#include "HsVersions.h"
import GhcPrelude
import ByteCodeTypes
import GHCi
import GHC.ByteCode.Types
import GHC.Runtime.Interpreter
import DynFlags
import HscTypes
import Name ( Name, getName )
......
......@@ -4,8 +4,8 @@
-- (c) The University of Glasgow 2002-2006
--
-- | ByteCodeInstrs: Bytecode instruction definitions
module ByteCodeInstr (
-- | Bytecode instruction definitions
module GHC.ByteCode.Instr (
BCInstr(..), ProtoBCO(..), bciStackUse,
) where
......@@ -13,7 +13,7 @@ module ByteCodeInstr (
import GhcPrelude
import ByteCodeTypes
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import GHC.StgToCmm.Layout ( ArgRep(..) )
......@@ -28,7 +28,7 @@ import Literal
import DataCon
import VarSet
import PrimOp
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import Data.Word
import GHC.Stack.CCS (CostCentre)
......
......@@ -8,8 +8,8 @@
-- (c) The University of Glasgow 2002-2006
--
-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeLink (
-- | Bytecode assembler and linker
module GHC.ByteCode.Linker (
ClosureEnv, emptyClosureEnv, extendClosureEnv,
linkBCO, lookupStaticPtr,
lookupIE,
......@@ -25,8 +25,8 @@ import GHCi.ResolvedBCO
import GHCi.BreakArray
import SizedSeq
import GHCi
import ByteCodeTypes
import GHC.Runtime.Interpreter
import GHC.ByteCode.Types
import HscTypes
import Name
import NameEnv
......@@ -90,7 +90,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
m <- lookupSymbol hsc_env addr_of_label_string
case m of
Just ptr -> return ptr
Nothing -> linkFail "ByteCodeLink: can't find label"
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
(unpackFS addr_of_label_string)
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
......@@ -108,7 +108,7 @@ lookupIE hsc_env ie con_nm =
n <- lookupSymbol hsc_env sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "ByteCodeLink.lookupIE"
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
(unpackFS sym_to_find1 ++ " or " ++
unpackFS sym_to_find2)
......@@ -118,7 +118,7 @@ lookupPrimOp hsc_env primop = do
m <- lookupSymbol hsc_env (mkFastString sym_to_find)
case m of
Just p -> return (toRemotePtr p)
Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
resolvePtr
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
......@@ -135,7 +135,7 @@ resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
m <- lookupSymbol hsc_env sym_to_find
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
......
......@@ -4,7 +4,7 @@
--
-- | Bytecode assembler types
module ByteCodeTypes
module GHC.ByteCode.Types
( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
......@@ -114,7 +114,7 @@ data CgBreakInfo
{ cgb_vars :: [Maybe (Id,Word16)]
, cgb_resty :: Type
}
-- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
-- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
......
......@@ -3,12 +3,11 @@
module GHC.Cmm (
-- * Cmm top-level datatypes
CmmProgram, CmmGroup, GenCmmGroup,
CmmDecl, GenCmmDecl(..),
CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
CmmGraph, GenCmmGraph(..),
CmmBlock,
RawCmmDecl, RawCmmGroup,
Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
CmmBlock, RawCmmDecl,
Section(..), SectionType(..), CmmStatics(..), RawCmmStatics(..), CmmStatic(..),
isSecConstant,
-- ** Blocks containing lists
......@@ -32,7 +31,7 @@ import CostCentre
import GHC.Cmm.CLabel
import GHC.Cmm.BlockId
import GHC.Cmm.Node
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Expr
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
......@@ -56,8 +55,12 @@ import Data.ByteString (ByteString)
type CmmProgram = [CmmGroup]
type GenCmmGroup d h g = [GenCmmDecl d h g]
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
-- | Cmm group before SRT generation
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
-- | Cmm group with SRTs
type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph
-- | "Raw" cmm group (TODO (osa): not sure what that means)
type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl
......@@ -89,12 +92,13 @@ data GenCmmDecl d h g
Section
d
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
type RawCmmDecl
= GenCmmDecl
CmmStatics
(LabelMap CmmStatics)
RawCmmStatics
(LabelMap RawCmmStatics)
CmmGraph
-----------------------------------------------------------------------------
......@@ -199,8 +203,20 @@ data CmmStatic
| CmmString ByteString
-- string of 8-bit values only, not zero terminated.
-- Static data before SRT generation
data CmmStatics
= Statics
= CmmStatics
CLabel -- Label of statics
CmmInfoTable
CostCentreStack
[CmmLit] -- Payload
| CmmStaticsRaw
CLabel -- Label of statics
[CmmStatic] -- The static data itself
-- Static data, after SRTs are generated
data RawCmmStatics
= RawCmmStatics
CLabel -- Label of statics
[CmmStatic] -- The static data itself
......
......@@ -7,6 +7,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module GHC.Cmm.CLabel (
CLabel, -- abstract type
......@@ -106,7 +107,8 @@ module GHC.Cmm.CLabel (
pprCLabel,
isInfoTableLabel,
isConInfoTableLabel
isConInfoTableLabel,
isIdLabel
) where
#include "HsVersions.h"
......@@ -262,6 +264,10 @@ data CLabel
deriving Eq
isIdLabel :: CLabel -> Bool
isIdLabel IdLabel{} = True
isIdLabel _ = False
-- This is laborious, but necessary. We can't derive Ord because
-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
-- implementation. See Note [No Ord for Unique]
......@@ -463,7 +469,7 @@ mkRednCountsLabel name =
mkLocalClosureLabel :: Name -> CafInfo -> CLabel
mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel
mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
mkLocalClosureLabel name c = IdLabel name c Closure
mkLocalClosureLabel !name !c = IdLabel name c Closure
mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable
mkLocalClosureTableLabel name c = IdLabel name c ClosureTable
......
......@@ -8,7 +8,7 @@ module GHC.Cmm.CallConv (
import GhcPrelude
import GHC.Cmm.Expr
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import GHC.Cmm (Convention(..))
import GHC.Cmm.Ppr () -- For Outputable instances
......
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Cmm.ContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
......
......@@ -167,11 +167,14 @@ instance IsMap UniqueMap where
mapFoldr k z (UM m) = M.foldr k z m
mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
{-# INLINEABLE mapFilter #-}
mapFilter f (UM m) = UM (M.filter f m)
{-# INLINEABLE mapFilterWithKey #-}
mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
mapElems (UM m) = M.elems m
mapKeys (UM m) = M.keys m
{-# INLINEABLE mapToList #-}
mapToList (UM m) = M.toList m
mapFromList assocs = UM (M.fromList assocs)
mapFromListWith f assocs = UM (M.fromListWith f assocs)
......@@ -107,11 +107,14 @@ instance IsMap LabelMap where
mapFoldlWithKey k z (LM m) =
mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
{-# INLINEABLE mapFilter #-}
mapFilter f (LM m) = LM (mapFilter f m)
{-# INLINEABLE mapFilterWithKey #-}
mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
mapElems (LM m) = mapElems m
mapKeys (LM m) = map mkHooplLabel (mapKeys m)
{-# INLINEABLE mapToList #-}
mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
......
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
--
-- Debugging data
......@@ -159,7 +161,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
, dblCLabel = case info of
Just (Statics infoLbl _) -> infoLbl
Just (RawCmmStatics infoLbl _) -> infoLbl
Nothing
| g_entry graph == label -> entryLbl
| otherwise -> blockLbl label
......
......@@ -35,7 +35,7 @@ import DynFlags
import FastString
import ForeignCall
import OrdList
import GHC.Runtime.Layout (ByteOff)
import GHC.Runtime.Heap.Layout (ByteOff)
import UniqSupply
import Util
import Panic
......
......@@ -2,7 +2,6 @@
module GHC.Cmm.Info (
mkEmptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
srtEscape,
-- info table accessors
......@@ -39,7 +38,7 @@ import GhcPrelude
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import GHC.Data.Bitmap
import Stream (Stream)
import qualified Stream
......@@ -67,11 +66,11 @@ mkEmptyContInfoTable info_lbl
, cit_srt = Nothing
, cit_clo = Nothing }
cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a
cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl])
do_one uniqs cmm =
-- NB. strictness fixes a space leak. DO NOT REMOVE.
withTimingSilent dflags (text "Cmm -> Raw Cmm")
......@@ -117,9 +116,8 @@ cmmToRawCmm dflags cmms
--
-- * The SRT slot is only there if there is SRT info to record
mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]
mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
--
......@@ -169,7 +167,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
--
return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
......@@ -423,7 +421,7 @@ mkProfLits _ (ProfilingInfo td cd)
; (cd_lit, cd_decl) <- newStringLit cd
; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit bytes
= do { uniq <- getUniqueM
; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
......
This diff is collapsed.
......@@ -18,7 +18,7 @@ import GHC.Cmm.Graph
import ForeignCall
import GHC.Cmm.Liveness
import GHC.Cmm.ProcPoint
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
......
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Cmm.MachOp
( MachOp(..)
, pprMachOp, isCommutableMachOp, isAssociativeMachOp
......
......@@ -9,6 +9,8 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- CmmNode type for representation using Hoopl graphs.
......@@ -33,7 +35,7 @@ import DynFlags
import FastString
import ForeignCall
import Outputable
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import CoreSyn (Tickish)
import qualified Unique as U
......
......@@ -231,7 +231,7 @@ import GHC.Cmm.BlockId
import GHC.Cmm.Lexer
import GHC.Cmm.CLabel
import GHC.Cmm.Monad
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import Lexer
import CostCentre
......@@ -394,7 +394,7 @@ cmmdata :: { CmmParse () }
: 'section' STRING '{' data_label statics '}'
{ do lbl <- $4;
ss <- sequence $5;
code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }
data_label :: { CmmParse CLabel }
: NAME ':'
......@@ -1175,7 +1175,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits
foreignCall
:: String
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module GHC.Cmm.Pipeline (
-- | Converts C-- with an implicit stack and native C-- calls into
......@@ -27,6 +29,7 @@ import HscTypes
import Control.Monad
import Outputable
import GHC.Platform
import Data.Either (partitionEithers)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
......@@ -37,14 +40,15 @@ cmmPipeline
-- dynamic flags: -dcmm-lint -ddump-cmm-cps
-> ModuleSRTInfo -- Info about SRTs generated so far
-> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
-> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--
cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
let (procs, data_) = partitionEithers tops
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_
dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)
return (srtInfo, cmms)
......@@ -54,8 +58,8 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline")
dflags = hsc_dflags hsc_env
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p))
cpsTop hsc_env proc =
do
----------- Control-flow optimisations ----------------------------------
......@@ -85,7 +89,9 @@ cpsTop hsc_env proc =
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- Proc points -------------------------------------------------
let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
let
call_pps :: ProcPointSet -- LabelMap
call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
proc_points <-
if splitting_proc_points
then do
......@@ -144,7 +150,7 @@ cpsTop hsc_env proc =
-- See Note [unreachable blocks]
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
return (cafEnv, g)
return (Left (cafEnv, g))
where dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
......
......@@ -54,13 +54,13 @@ import qualified Data.ByteString as BS
pprCmms :: (Outputable info, Outputable g)
=> [GenCmmGroup CmmStatics info g] -> SDoc
=> [GenCmmGroup RawCmmStatics info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ text "-------------------" $$ space
writeCmms :: (Outputable info, Outputable g)
=> DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
=> DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
-----------------------------------------------------------------------------
......@@ -72,6 +72,9 @@ instance (Outputable d, Outputable info, Outputable i)
instance Outputable CmmStatics where
ppr = pprStatics
instance Outputable RawCmmStatics where
ppr = pprRawStatics
instance Outputable CmmStatic where
ppr = pprStatic
......@@ -136,8 +139,14 @@ instance Outputable ForeignHint where
-- Strings are printed as C strings, and we print them as I8[],
-- following C--
--
pprStatics :: CmmStatics -> SDoc
pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
pprStatics (CmmStatics lbl itbl ccs payload) =
ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload
pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds)
pprRawStatics :: RawCmmStatics -> SDoc
pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
......
{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Cmm.ProcPoint
( ProcPointSet, Status(..)
......
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Cmm.Switch (
SwitchTargets,
mkSwitchTargets,
......
{-# LANGUAGE GADTs, RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
--
-- Cmm utilities.
......@@ -73,7 +75,7 @@ import GhcPrelude
import TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 )
import GHC.Runtime.Layout
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
......@@ -190,22 +192,22 @@ mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
mkByteStringCLit
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit lbl bytes
= (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
= (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes])
where
-- This can not happen for String literals (as there \NUL is replaced by
-- C0 80). However, it can happen with Addr# literals.
sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
-- Build a data-segment data block
mkDataLits section lbl lits
= CmmData section (Statics lbl $ map CmmStaticLit lits)
= CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits)
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
-- Build a read-only data block
mkRODataLits lbl lits
= mkDataLits section lbl lits
......
......@@ -55,7 +55,7 @@ import qualified Data.ByteString as BS
import Control.Monad.ST
import Data.Bits
import Data.Char
import Data.List
import Data.List (intersperse)
import Data.Map (Map)
import Data.Word
import System.IO
......@@ -87,7 +87,7 @@ pprTop (CmmProc infos clbl _in_live_regs graph) =
(case mapLookup (g_entry graph) infos of
Nothing -> empty
Just (Statics info_clbl info_dat) ->
Just (RawCmmStatics info_clbl info_dat) ->
pprDataExterns info_dat $$
pprWordArray info_is_in_rodata info_clbl info_dat) $$
(vcat [
......@@ -110,21 +110,21 @@ pprTop (CmmProc infos clbl _in_live_regs graph) =
-- We only handle (a) arrays of word-sized things and (b) strings.
pprTop (CmmData section (Statics lbl [CmmString str])) =
pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) =
pprExternDecl lbl $$
hcat [
pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
text "[] = ", pprStringInCStyle str, semi
]
pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =
pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) =
pprExternDecl lbl $$
hcat [
pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
brackets (int size), semi
]
pprTop (CmmData section (Statics lbl lits)) =
pprTop (CmmData section (RawCmmStatics lbl lits)) =