summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorJose Pedro Magalhaes <jpm@cs.uu.nl>2011-05-09 14:04:37 +0200
committerJose Pedro Magalhaes <jpm@cs.uu.nl>2011-05-09 14:04:37 +0200
commit61d89bc49eb75d74ed9196ba5f7b7b32018b914b (patch)
tree9402c5e2b5be383dd78ad000a5753ce784d3b5cd /compiler
parentc7cb47fc0e98e660621bfe7368464c4c93c9dbf1 (diff)
parent37a6a52facd1c3999ce4472c50b0030568be1e04 (diff)
downloadhaskell-61d89bc49eb75d74ed9196ba5f7b7b32018b914b.tar.gz
Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Module.lhs6
-rw-r--r--compiler/cmm/CmmOpt.hs41
-rw-r--r--compiler/cmm/PprC.hs15
-rw-r--r--compiler/ghc.mk90
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs29
-rw-r--r--compiler/ghci/ByteCodeGen.lhs736
-rw-r--r--compiler/main/CmdLineParser.hs2
-rw-r--r--compiler/main/DriverPipeline.hs22
-rw-r--r--compiler/main/DynFlags.hs39
-rw-r--r--compiler/main/ErrUtils.lhs3
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs17
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs4
-rw-r--r--compiler/nativeGen/SPARC/Ppr.hs7
-rw-r--r--compiler/nativeGen/X86/Ppr.hs9
-rw-r--r--compiler/typecheck/TcRnMonad.lhs4
-rw-r--r--compiler/utils/Outputable.lhs281
-rw-r--r--compiler/utils/Platform.hs (renamed from compiler/nativeGen/Platform.hs)0
-rw-r--r--compiler/utils/Pretty.lhs7
18 files changed, 633 insertions, 679 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 03f541e505..89b3eddfd7 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -73,7 +73,6 @@ module Module
import Config
import Outputable
-import qualified Pretty
import Unique
import UniqFM
import FastString
@@ -253,9 +252,10 @@ mkModule :: PackageId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
-pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
+pprModule mod@(Module p n) =
+ pprPackagePrefix p mod <> pprModuleName n
-pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
+pprPackagePrefix :: PackageId -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 1c7e7e53cb..a2eecd5c48 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -37,6 +37,7 @@ import Data.Bits
import Data.Word
import Data.Int
import Data.Maybe
+import Data.List
import Compiler.Hoopl hiding (Unique)
@@ -57,11 +58,9 @@ cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
cmmEliminateDeadBlocks [] = []
cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
let -- Calculate what's reachable from what block
- -- We have to do a deep fold into CmmExpr because
- -- there may be a BlockId in the CmmBlock literal.
- reachableMap = foldl f emptyBlockMap blocks
- where f m (BasicBlock block_id stmts) = mapInsert block_id (reachableFrom stmts) m
- reachableFrom stmts = foldl stmt emptyBlockSet stmts
+ reachableMap = foldl' f emptyUFM blocks -- lazy in values
+ where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+ reachableFrom stmts = foldl stmt [] stmts
where
stmt m CmmNop = m
stmt m (CmmComment _) = m
@@ -70,30 +69,30 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt m (CmmCall c _ as _ _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _) = m
- stmt m (CmmBranch b) = setInsert b m
- stmt m (CmmCondBranch e b) = setInsert b (expr m e)
- stmt m (CmmSwitch e bs) = foldl (flip setInsert) (expr m e) (catMaybes bs)
+ stmt m (CmmBranch b) = b:m
+ stmt m (CmmCondBranch e b) = b:(expr m e)
+ stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e as) = expr (actuals m as) e
stmt m (CmmReturn as) = actuals m as
- actuals m as = foldl (\m h -> expr m (hintlessCmm h)) m as
+ actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+ -- We have to do a deep fold into CmmExpr because
+ -- there may be a BlockId in the CmmBlock literal.
expr m (CmmLit l) = lit m l
expr m (CmmLoad e _) = expr m e
expr m (CmmReg _) = m
- expr m (CmmMachOp _ es) = foldl expr m es
+ expr m (CmmMachOp _ es) = foldl' expr m es
expr m (CmmStackSlot _ _) = m
expr m (CmmRegOff _ _) = m
- lit m (CmmBlock b) = setInsert b m
+ lit m (CmmBlock b) = b:m
lit m _ = m
- -- Expand reachable set until you hit fixpoint
- initReachable = setSingleton base_id :: BlockSet
- expandReachable old_set new_set =
- if setSize new_set > setSize old_set
- then expandReachable new_set $ setFold
- (\x s -> maybe setEmpty id (mapLookup x reachableMap) `setUnion` s)
- new_set
- (setDifference new_set old_set)
- else new_set -- fixpoint achieved
- reachable = expandReachable setEmpty initReachable
+ -- go todo done
+ reachable = go [base_id] (setEmpty :: BlockSet)
+ where go [] m = m
+ go (x:xs) m
+ | setMember x m = go xs m
+ | otherwise = go (add ++ xs) (setInsert x m)
+ where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+ (lookupUFM reachableMap x)
in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 10f4e8bacf..aa7d914253 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -64,10 +64,6 @@ import Data.Word
import Data.Array.ST
import Control.Monad.ST
-#if x86_64_TARGET_ARCH
-import StaticFlags ( opt_Unregisterised )
-#endif
-
#if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
#define BEWARE_LOAD_STORE_ALIGNMENT
#endif
@@ -820,17 +816,6 @@ pprCall ppr_fn cconv results args _
| otherwise
=
-#if x86_64_TARGET_ARCH
- -- HACK around gcc optimisations.
- -- x86_64 needs a __DISCARD__() here, to create a barrier between
- -- putting the arguments into temporaries and passing the arguments
- -- to the callee, because the argument expressions may refer to
- -- machine registers that are also used for passing arguments in the
- -- C calling convention.
- (if (not opt_Unregisterised)
- then ptext (sLit "__DISCARD__();")
- else empty) $$
-#endif
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 55ebb84ac9..2254332eb7 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -49,8 +49,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo '{-# LANGUAGE CPP #-}' >> $@
@echo 'module Config where' >> $@
@echo >> $@
- @echo 'import Distribution.System' >> $@
- @echo >> $@
@echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@
@@ -60,94 +58,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cTargetPlatformString :: String' >> $@
@echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@
@echo >> $@
-# Sync this with checkArch in configure.ac
- @echo 'cTargetArch :: Arch' >> $@
- @echo '#if i386_TARGET_ARCH' >> $@
- @echo 'cTargetArch = I386' >> $@
- @echo '#elif x86_64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = X86_64' >> $@
- @echo '#elif powerpc_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC' >> $@
- @echo '#elif powerpc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC64' >> $@
- @echo '#elif sparc_TARGET_ARCH || sparc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Sparc' >> $@
- @echo '#elif arm_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Arm' >> $@
- @echo '#elif mips_TARGET_ARCH || mipseb_TARGET_ARCH || mipsel_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Mips' >> $@
- @echo '#elif 0' >> $@
- @echo 'cTargetArch = SH' >> $@
- @echo '#elif ia64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = IA64' >> $@
- @echo '#elif s390_TARGET_ARCH' >> $@
- @echo 'cTargetArch = S390' >> $@
- @echo '#elif alpha_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Alpha' >> $@
- @echo '#elif hppa_TARGET_ARCH || hppa1_1_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Hppa' >> $@
- @echo '#elif rs6000_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Rs6000' >> $@
- @echo '#elif m68k_TARGET_ARCH' >> $@
- @echo 'cTargetArch = M68k' >> $@
- @echo '#elif vax_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Vax' >> $@
- @echo '#else' >> $@
- @echo '#error Unknown target arch' >> $@
- @echo '#endif' >> $@
- @echo >> $@
-# Sync this with checkOS in configure.ac
- @echo 'cTargetOS :: OS' >> $@
- @echo '#if linux_TARGET_OS' >> $@
- @echo 'cTargetOS = Linux' >> $@
- @echo '#elif freebsd_TARGET_OS' >> $@
- @echo 'cTargetOS = FreeBSD' >> $@
- @echo '#elif netbsd_TARGET_OS' >> $@
- @echo 'cTargetOS = NetBSD' >> $@
- @echo '#elif openbsd_TARGET_OS' >> $@
- @echo 'cTargetOS = OpenBSD' >> $@
- @echo '#elif dragonfly_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "dragonfly"' >> $@
- @echo '#elif osf1_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "osf"' >> $@
- @echo '#elif osf3_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "osf"' >> $@
- @echo '#elif hpux_TARGET_OS' >> $@
- @echo 'cTargetOS = HPUX' >> $@
- @echo '#elif linuxaout_TARGET_OS' >> $@
- @echo 'cTargetOS = Linux' >> $@
- @echo '#elif kfreebsdgnu_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "kfreebsdgnu"' >> $@
- @echo '#elif freebsd2_TARGET_OS' >> $@
- @echo 'cTargetOS = FreeBSD' >> $@
- @echo '#elif solaris2_TARGET_OS' >> $@
- @echo 'cTargetOS = Solaris' >> $@
- @echo '#elif cygwin32_TARGET_OS' >> $@
- @echo 'cTargetOS = Windows' >> $@
- @echo '#elif mingw32_TARGET_OS' >> $@
- @echo 'cTargetOS = Windows' >> $@
- @echo '#elif darwin_TARGET_OS' >> $@
- @echo 'cTargetOS = OSX' >> $@
- @echo '#elif gnu_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "gnu"' >> $@
- @echo '#elif nextstep2_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "nextstep"' >> $@
- @echo '#elif nextstep3_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "nextstep"' >> $@
- @echo '#elif sunos4_TARGET_OS' >> $@
- @echo 'cTargetOS = Solaris' >> $@
- @echo '#elif ultrix_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "ultrix"' >> $@
- @echo '#elif irix_TARGET_OS' >> $@
- @echo 'cTargetOS = IRIX' >> $@
- @echo '#elif aix_TARGET_OS' >> $@
- @echo 'cTargetOS = AIX' >> $@
- @echo '#elif haiku_TARGET_OS' >> $@
- @echo 'cTargetOS = OtherOS "haiku"' >> $@
- @echo '#else' >> $@
- @echo '#error Unknown target OS' >> $@
- @echo '#endif' >> $@
- @echo >> $@
@echo 'cProjectName :: String' >> $@
@echo 'cProjectName = "$(ProjectName)"' >> $@
@echo 'cProjectVersion :: String' >> $@
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 2c7473b80c..af9fbe9049 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -30,8 +30,9 @@ import PrimOp
import Constants
import FastString
import SMRep
+import DynFlags
import Outputable
-import Config
+import Platform
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
@@ -45,7 +46,6 @@ import Data.Char ( ord )
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
-import Distribution.System
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
@@ -115,14 +115,14 @@ instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
-assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs proto_bcos tycons
+assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls tycons
- bcos <- mapM assembleBCO proto_bcos
+ bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset
@@ -154,7 +154,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
let init_asm_state = (insns,lits,ptrs)
(final_insns, final_lits, final_ptrs)
- <- mkBits findLabel init_asm_state instrs
+ <- mkBits dflags findLabel init_asm_state instrs
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
@@ -230,12 +230,13 @@ largeArg w
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word) -- label finder
+mkBits :: DynFlags
+ -> (Word16 -> Word) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
-mkBits findLabel st proto_insns
+mkBits dflags findLabel st proto_insns
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
@@ -249,14 +250,14 @@ mkBits findLabel st proto_insns
instr2 st2 bci_PUSH_G p
PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
instr2 st2 bci_PUSH_G p
- PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_G p
- PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_ALTS p
PUSH_ALTS_UNLIFTED proto pk -> do
- ul_bco <- assembleBCO proto
+ ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
@@ -398,7 +399,7 @@ mkBits findLabel st proto_insns
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
literal st (MachLabel fs (Just sz) _)
- | cTargetOS == Windows
+ | platformOS (targetPlatform dflags) == OSMinGW32
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index f34ac9c172..b888747d82 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -30,9 +30,7 @@ import CoreFVs
import Type
import DataCon
import TyCon
--- import Type
import Util
--- import DataCon
import Var
import VarSet
import TysPrim
@@ -50,38 +48,36 @@ import Data.List
import Foreign
import Foreign.C
--- import GHC.Exts ( Int(..) )
-
-import Control.Monad ( when )
+import Control.Monad
import Data.Char
import UniqSupply
import BreakArray
import Data.Maybe
-import Module
-import IdInfo
+import Module
+import IdInfo
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
-- -----------------------------------------------------------------------------
--- Generating byte code for a complete module
+-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
- -> [TyCon]
- -> ModBreaks
+ -> [TyCon]
+ -> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags binds tycs modBreaks
+byteCodeGen dflags binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
- let flatBinds = [ (bndr, freeVars rhs)
- | (bndr, rhs) <- flattenBinds binds]
+ let flatBinds = [ (bndr, freeVars rhs)
+ | (bndr, rhs) <- flattenBinds binds]
- us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _, proto_bcos)
- <- runBc us modBreaks (mapM schemeTopBind flatBinds)
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us _final_ctr mallocd _, proto_bcos)
+ <- runBc us modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -89,15 +85,15 @@ byteCodeGen dflags binds tycs modBreaks
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- assembleBCOs proto_bcos tycs
-
+ assembleBCOs dflags proto_bcos tycs
+
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
--- Returns: (the root BCO for this expression,
+-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
- -> CoreExpr
+ -> CoreExpr
-> IO UnlinkedBCO
coreExprToBCOs dflags expr
= do showPass dflags "ByteCodeGen"
@@ -106,11 +102,11 @@ coreExprToBCOs dflags expr
-- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
-
+
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _ , proto_bco)
+ (BcM_State _us _final_ctr mallocd _ , proto_bco)
<- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
@@ -118,7 +114,7 @@ coreExprToBCOs dflags expr
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
- assembleBCO proto_bco
+ assembleBCO dflags proto_bco
-- -----------------------------------------------------------------------------
@@ -152,18 +148,18 @@ mkProtoBCO
-> Int
-> Word16
-> [StgWord]
- -> Bool -- True <=> is a return point, rather than a function
+ -> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
- protoBCOName = nm,
- protoBCOInstrs = maybe_with_stack_check,
- protoBCOBitmap = bitmap,
- protoBCOBitmapSize = bitmap_size,
- protoBCOArity = arity,
- protoBCOExpr = origin,
- protoBCOPtrs = mallocd_blocks
+ protoBCOName = nm,
+ protoBCOInstrs = maybe_with_stack_check,
+ protoBCOBitmap = bitmap,
+ protoBCOBitmapSize = bitmap_size,
+ protoBCOArity = arity,
+ protoBCOExpr = origin,
+ protoBCOPtrs = mallocd_blocks
}
where
-- Overestimate the stack usage (in words) of this BCO,
@@ -174,17 +170,17 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
- | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
- -- don't do stack checks at return points,
- -- everything is aggregated up to the top BCO
- -- (which must be a function).
+ | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+ -- don't do stack checks at return points,
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function).
-- That is, unless the stack usage is >= AP_STACK_SPLIM,
-- see bug #1466.
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_usage : peep_d
| otherwise
- = peep_d -- the supposedly common case
-
+ = peep_d -- the supposedly common case
+
-- We assume that this sum doesn't wrap
stack_usage = sum (map bciStackUse peep_d)
@@ -214,19 +210,19 @@ argBits (rep : args)
schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
- -- Special case for the worker of a nullary data con.
- -- It'll look like this: Nil = /\a -> Nil a
- -- If we feed it into schemeR, we'll get
- -- Nil = Nil
- -- because mkConAppCode treats nullary constructor applications
- -- by just re-using the single top-level definition. So
- -- for the worker itself, we must allocate it directly.
+ -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
+ -- If we feed it into schemeR, we'll get
+ -- Nil = Nil
+ -- because mkConAppCode treats nullary constructor applications
+ -- by just re-using the single top-level definition. So
+ -- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
@@ -242,13 +238,13 @@ schemeTopBind (id, rhs)
--
-- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the
--- resulting BCO a name.
+-- resulting BCO a name.
-schemeR :: [Id] -- Free vars of the RHS, ordered as they
- -- will appear in the thunk. Empty for
- -- top-level things, which have no free vars.
- -> (Id, AnnExpr Id VarSet)
- -> BcM (ProtoBCO Name)
+schemeR :: [Id] -- Free vars of the RHS, ordered as they
+ -- will appear in the thunk. Empty for
+ -- top-level things, which have no free vars.
+ -> (Id, AnnExpr Id VarSet)
+ -> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
@@ -269,40 +265,40 @@ collect (_, e) = go [] e
go xs (AnnLam x (_,e)) = go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
- = let
- all_args = reverse args ++ fvs
- arity = length all_args
- -- all_args are the args in reverse order. We're compiling a function
- -- \fv1..fvn x1..xn -> e
- -- i.e. the fvs come first
+ = let
+ all_args = reverse args ++ fvs
+ arity = length all_args
+ -- all_args are the args in reverse order. We're compiling a function
+ -- \fv1..fvn x1..xn -> e
+ -- i.e. the fvs come first
szsw_args = map (fromIntegral . idSizeW) all_args
szw_args = sum szsw_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
- -- make the arg bitmap
- bits = argBits (reverse (map idCgRep all_args))
- bitmap_size = genericLength bits
- bitmap = mkBitmap bits
+ -- make the arg bitmap
+ bits = argBits (reverse (map idCgRep all_args))
+ bitmap_size = genericLength bits
+ bitmap = mkBitmap bits
in do
- body_code <- schemeER_wrk szw_args p_init body
-
+ body_code <- schemeER_wrk szw_args p_init body
+
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
- arity bitmap_size bitmap False{-not alts-})
+ arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk d p rhs
- | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
- code <- schemeE d 0 p newRhs
- arr <- getBreakArray
+ | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+ code <- schemeE d 0 p newRhs
+ arr <- getBreakArray
let idOffSets = getVarOffSets d p tickInfo
let tickNumber = tickInfo_number tickInfo
- let breakInfo = BreakInfo
+ let breakInfo = BreakInfo
{ breakInfo_module = tickInfo_module tickInfo
- , breakInfo_number = tickNumber
+ , breakInfo_number = tickNumber
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
@@ -310,15 +306,15 @@ schemeER_wrk d p rhs
BA arr# ->
BRK_FUN arr# (fromIntegral tickNumber) breakInfo
return $ breakInstr `consOL` code
- | otherwise = schemeE d 0 p rhs
+ | otherwise = schemeE d 0 p rhs
getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
-getOffSet d env id
+getOffSet d env id
= case lookupBCEnv_maybe id env of
- Nothing -> Nothing
+ Nothing -> Nothing
Just offset -> Just (id, d - offset)
fvsToEnv :: BCEnv -> VarSet -> [Id]
@@ -330,22 +326,22 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs,
- isId v, -- Could be a type variable
- v `Map.member` p]
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+ isId v, -- Could be a type variable
+ v `Map.member` p]
-- -----------------------------------------------------------------------------
-- schemeE
-data TickInfo
- = TickInfo
+data TickInfo
+ = TickInfo
{ tickInfo_number :: Int -- the (module) unique number of the tick
- , tickInfo_module :: Module -- the origin of the ticked expression
+ , tickInfo_module :: Module -- the origin of the ticked expression
, tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
- }
+ }
instance Outputable TickInfo where
- ppr info = text "TickInfo" <+>
+ ppr info = text "TickInfo" <+>
parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
ppr (tickInfo_locals info))
@@ -358,7 +354,7 @@ schemeE d s p e
= schemeE d s p e'
-- Delegate tail-calls to schemeT.
-schemeE d s p e@(AnnApp _ _)
+schemeE d s p e@(AnnApp _ _)
= schemeT d s p e
schemeE d s p e@(AnnVar v)
@@ -367,12 +363,12 @@ schemeE d s p e@(AnnVar v)
schemeT d s p e
| otherwise
- = do -- Returning an unlifted value.
+ = do -- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
(push, szw) <- pushAtom d p (AnnVar v)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX v_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
v_rep = typeCgRep v_type
@@ -380,17 +376,17 @@ schemeE d s p e@(AnnVar v)
schemeE d s p (AnnLit literal)
= do (push, szw) <- pushAtom d p (AnnLit literal)
let l_rep = typeCgRep (literalType literal)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX l_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX l_rep) -- go
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
- = do -- Special case for a non-recursive let whose RHS is a
- -- saturatred constructor application.
- -- Just allocate the constructor and carry on
+ = do -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
body_code <- schemeE (d+1) s (Map.insert x d p) body
return (alloc_code `appOL` body_code)
@@ -407,8 +403,8 @@ schemeE d s p (AnnLet binds (_,body))
-- Sizes of free vars
sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
- -- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ -- the arity of each rhs
+ arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1. d' and p' reflect the stack
@@ -421,33 +417,33 @@ schemeE d s p (AnnLet binds (_,body))
-- ToDo: don't build thunks for things with no free variables
build_thunk _ [] size bco off arity
= return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
- where
- mkap | arity == 0 = MKAP
- | otherwise = MKPAP
+ where
+ mkap | arity == 0 = MKAP
+ | otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
- (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
+ (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
- where mkAlloc sz 0
+ where mkAlloc sz 0
| is_tick = ALLOC_AP_NOUPD sz
| otherwise = ALLOC_AP sz
- mkAlloc sz arity = ALLOC_PAP arity sz
+ mkAlloc sz arity = ALLOC_PAP arity sz
- is_tick = case binds of
+ is_tick = case binds of
AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
- compile_bind d' fvs x rhs size arity off = do
- bco <- schemeR fvs (x,rhs)
- build_thunk d' fvs size bco off arity
+ compile_bind d' fvs x rhs size arity off = do
+ bco <- schemeR fvs (x,rhs)
+ build_thunk d' fvs size bco off arity
- compile_binds =
- [ compile_bind d' fvs x rhs size arity n
- | (fvs, x, rhs, size, arity, n) <-
- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
- ]
+ compile_binds =
+ [ compile_bind d' fvs x rhs size arity n
+ | (fvs, x, rhs, size, arity, n) <-
+ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+ ]
in do
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
@@ -464,7 +460,7 @@ schemeE d s p exp@(AnnCase {})
= if isUnLiftedType ty
then do
-- If the result type is unlifted, then we must generate
- -- let f = \s . case tick# of _ -> e
+ -- let f = \s . case tick# of _ -> e
-- in f realWorld#
-- When we stop at the breakpoint, _result will have an unlifted
-- type and hence won't be bound in the environment, but the
@@ -472,7 +468,7 @@ schemeE d s p exp@(AnnCase {})
id <- newId (mkFunTy realWorldStatePrimTy ty)
st <- newId realWorldStatePrimTy
let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
- (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
+ (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
(emptyVarSet, AnnVar realWorldPrimId)))
schemeE d s p letExp
else do
@@ -486,42 +482,42 @@ schemeE d s p exp@(AnnCase {})
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
- -- Convert
- -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
- -- becuse the return convention for both are identical.
- --
- -- Note that it does not matter losing the void-rep thing from the
- -- envt (it won't be bound now) because we never look such things up.
+ -- Convert
+ -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- becuse the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
- doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
- -- Similarly, convert
- -- case .... of x { (# a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
+ -- Similarly, convert
+ -- case .... of x { (# a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE _ _ _ expr
- = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' expr))
-{-
+{-
Ticked Expressions
------------------
-
+
A ticked expression looks like this:
case tick<n> var1 ... varN of DEFAULT -> e
@@ -535,7 +531,7 @@ schemeE _ _ _ expr
otherwise we return Nothing.
- The idea is that the "case tick<n> ..." is really just an annotation on
+ The idea is that the "case tick<n> ..." is really just an annotation on
the code. When we find such a thing, we pull out the useful information,
and then compile the code as if it was just the expression "e".
@@ -544,10 +540,10 @@ schemeE _ _ _ expr
isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
isTickedExp' (AnnCase scrut _bndr _type alts)
| Just tickInfo <- isTickedScrut scrut,
- [(DEFAULT, _bndr, rhs)] <- alts
+ [(DEFAULT, _bndr, rhs)] <- alts
= Just (tickInfo, rhs)
where
- isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
+ isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
isTickedScrut expr
| Var id <- f,
Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
@@ -559,7 +555,7 @@ isTickedExp' (AnnCase scrut _bndr _type alts)
where
(f, args) = collectArgs $ deAnnotate expr
idsOfArgs :: [Expr Id] -> [Id]
- idsOfArgs = catMaybes . map exprId
+ idsOfArgs = catMaybes . map exprId
exprId :: Expr Id -> Maybe Id
exprId (Var id) = Just id
exprId _ = Nothing
@@ -583,16 +579,16 @@ isTickedExp' _ = Nothing
-- (# b #) and treat it as b.
--
-- 3. Application of a constructor, by defn saturated.
--- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Word16 -- Stack depth
- -> Sequel -- Sequel depth
- -> BCEnv -- stack env
- -> AnnExpr' Id VarSet
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr' Id VarSet
-> BcM BCInstrList
schemeT d s p app
@@ -601,13 +597,13 @@ schemeT d s p app
-- = panic "schemeT ?!?!"
-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
--- = error "?!?!"
+-- = error "?!?!"
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= do (push, arg_words) <- pushAtom d p arg
tagToId_sequence <- implement_tagToId constr_names
- return (push `appOL` tagToId_sequence
+ return (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
@@ -619,20 +615,20 @@ schemeT d s p app
| Just con <- maybe_saturated_dcon,
isUnboxedTupleCon con
= case args_r_to_l of
- [arg1,arg2] | isVoidArgAtom arg1 ->
- unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVoidArgAtom arg2 ->
- unboxedTupleReturn d s p arg1
- _other -> unboxedTupleException
+ [arg1,arg2] | isVoidArgAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidArgAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
- return (alloc_con `appOL`
- mkSLIDE 1 (d - s) `snocOL`
- ENTER)
+ return (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
- -- Case 4: Tail call of function
+ -- Case 4: Tail call of function
| otherwise
= doTailCall d s p fn args_r_to_l
@@ -641,54 +637,54 @@ schemeT d s p app
maybe_is_tagToEnum_call
= let extract_constr_Names ty
| Just (tyc, _) <- splitTyConApp_maybe (repType ty),
- isDataTyCon tyc
- = map (getName . dataConWorkId) (tyConDataCons tyc)
- -- NOTE: use the worker name, not the source name of
- -- the DataCon. See DataCon.lhs for details.
- | otherwise
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
= pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
in
case app of
(AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
- _ -> Nothing
+ _ -> Nothing
_ -> Nothing
- -- Extract the args (R->L) and fn
- -- The function will necessarily be a variable,
- -- because we are compiling a tail call
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
(AnnVar fn, args_r_to_l) = splitApp app
-- Only consider this to be a constructor application iff it is
-- saturated. Otherwise, we'll call the constructor wrapper.
n_args = length args_r_to_l
- maybe_saturated_dcon
- = case isDataConWorkId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
-- -----------------------------------------------------------------------------
--- Generate code to build a constructor application,
+-- Generate code to build a constructor application,
-- leaving it on top of the stack
mkConAppCode :: Word16 -> Sequel -> BCEnv
- -> DataCon -- The data constructor
- -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
- -> BcM BCInstrList
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
-mkConAppCode _ _ _ con [] -- Nullary constructor
+mkConAppCode _ _ _ con [] -- Nullary constructor
= ASSERT( isNullaryRepDataCon con )
return (unitOL (PUSH_G (getName (dataConWorkId con))))
- -- Instead of doing a PACK, which would allocate a fresh
- -- copy of this constructor, use the single shared version.
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
-mkConAppCode orig_d _ p con args_r_to_l
+mkConAppCode orig_d _ p con args_r_to_l
= ASSERT( dataConRepArity con == length args_r_to_l )
do_pushery orig_d (non_ptr_args ++ ptr_args)
where
- -- The args are already in reverse order, which is the way PACK
- -- expects them to be. We must push the non-ptrs after the ptrs.
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
(ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
do_pushery d (arg:args)
@@ -697,8 +693,8 @@ mkConAppCode orig_d _ p con args_r_to_l
return (push `appOL` more_push_code)
do_pushery d []
= return (unitOL (PACK con n_arg_words))
- where
- n_arg_words = d - orig_d
+ where
+ n_arg_words = d - orig_d
-- -----------------------------------------------------------------------------
@@ -709,42 +705,42 @@ mkConAppCode orig_d _ p con args_r_to_l
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
- :: Word16 -> Sequel -> BCEnv
- -> AnnExpr' Id VarSet -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
- return (push `appOL`
- mkSLIDE sz (d-s) `snocOL`
- RETURN_UBX (atomRep arg))
+ return (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
doTailCall
- :: Word16 -> Sequel -> BCEnv
- -> Id -> [AnnExpr' Id VarSet]
- -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
doTailCall init_d s p fn args
= do_pushes init_d args (map atomRep args)
where
do_pushes d [] reps = do
- ASSERT( null reps ) return ()
+ ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- ASSERT( sz == 1 ) return ()
- return (push_fn `appOL` (
- mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
- unitOL ENTER))
+ ASSERT( sz == 1 ) return ()
+ return (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
do_pushes d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
- (these_args, rest_of_args) = splitAt n args
+ (these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
- instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
- -- ^^^ for the PUSH_APPLY_ instruction
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
- (push_code, sz) <- pushAtom d p arg
+ (push_code, sz) <- pushAtom d p arg
(final_d, more_push_code) <- push_seq (d+sz) args
return (final_d, push_code `appOL` more_push_code)
@@ -779,10 +775,10 @@ findPushSeq _
-- Case expressions
doCase :: Word16 -> Sequel -> BCEnv
- -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
- -> Bool -- True <=> is an unboxed tuple case, don't enter the result
- -> BcM BCInstrList
-doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
@@ -790,58 +786,58 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- on top of the itbl.
ret_frame_sizeW = 2
- -- An unlifted value gets an extra info table pushed on top
- -- when it is returned.
- unlifted_itbl_sizeW | isAlgCase = 0
- | otherwise = 1
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
- -- depth of stack after the return value has been pushed
- d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
- -- depth of stack after the extra info table for an unboxed return
- -- has been pushed, if any. This is the stack depth at the
- -- continuation.
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
d_alts = d_bndr + unlifted_itbl_sizeW
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
p_alts = Map.insert bndr (d_bndr - 1) p
- bndr_ty = idType bndr
+ bndr_ty = idType bndr
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeAlt (DEFAULT, _, (_,rhs))
- = do rhs_code <- schemeE d_alts s p_alts rhs
- return (NoDiscr, rhs_code)
+ codeAlt (DEFAULT, _, (_,rhs))
+ = do rhs_code <- schemeE d_alts s p_alts rhs
+ return (NoDiscr, rhs_code)
codeAlt alt@(_, bndrs, (_,rhs))
- -- primitive or nullary constructor alt: no need to UNPACK
- | null real_bndrs = do
- rhs_code <- schemeE d_alts s p_alts rhs
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
- -- algebraic alt with some binders
+ -- algebraic alt with some binders
| otherwise =
let
- (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
- ptr_sizes = map (fromIntegral . idSizeW) ptrs
- nptrs_sizes = map (fromIntegral . idSizeW) nptrs
- bind_sizes = ptr_sizes ++ nptrs_sizes
- size = sum ptr_sizes + sum nptrs_sizes
- -- the UNPACK instruction unpacks in reverse order...
- p' = Map.insertList
- (zip (reverse (ptrs ++ nptrs))
- (mkStackOffsets d_alts (reverse bind_sizes)))
- p_alts
- in do
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+ ptr_sizes = map (fromIntegral . idSizeW) ptrs
+ nptrs_sizes = map (fromIntegral . idSizeW) nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = Map.insertList
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ p_alts
+ in do
MASSERT(isAlgCase)
- rhs_code <- schemeE (d_alts+size) s p' rhs
+ rhs_code <- schemeE (d_alts+size) s p' rhs
return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
- where
- real_bndrs = filter (not.isTyCoVar) bndrs
+ where
+ real_bndrs = filter (not.isTyCoVar) bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
- my_discr (DataAlt dc, _, _)
+ my_discr (DataAlt dc, _, _)
| isUnboxedTupleCon dc
= unboxedTupleException
| otherwise
@@ -854,20 +850,20 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
- maybe_ncons
+ maybe_ncons
| not isAlgCase = Nothing
- | otherwise
+ | otherwise
= case [dc | (DataAlt dc, _, _) <- alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
- -- the bitmap is relative to stack depth d, i.e. before the
- -- BCO, info table and return value are pushed on.
- -- This bit of code is v. similar to buildLivenessMask in CgBindery,
- -- except that here we build the bitmap from the known bindings of
- -- things that are pointers, whereas in CgBindery the code builds the
- -- bitmap from the free slots and unboxed bindings.
- -- (ToDo: merge?)
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
--
-- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
-- The bitmap must cover the portion of the stack up to the sequel only.
@@ -878,32 +874,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
bitmap_size = d-s
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap bitmap_size'{-size-}
+ bitmap = intsToReverseBitmap bitmap_size'{-size-}
(sortLe (<=) (filter (< bitmap_size') rel_slots))
- where
- binds = Map.toList p
- rel_slots = map fromIntegral $ concat (map spread binds)
- spread (id, offset)
- | isFollowableArg (idCgRep id) = [ rel_offset ]
- | otherwise = []
- where rel_offset = d - offset - 1
+ where
+ binds = Map.toList p
+ rel_slots = map fromIntegral $ concat (map spread binds)
+ spread (id, offset)
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
- let
+ let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} bitmap_size bitmap True{-is alts-}
+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--- "\n bitmap = " ++ show bitmap) $ do
+-- "\n bitmap = " ++ show bitmap) $ do
scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
alt_bco' <- emitBc alt_bco
let push_alts
- | isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
return (push_alts `consOL` scrut_code)
@@ -914,17 +910,17 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- deferencing ForeignObj#s and adjusting addrs to point to
-- payloads in Ptr/Byte arrays. Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
--- then return in the right way.
+-- then return in the right way.
-generateCCall :: Word16 -> Sequel -- stack and sequel depths
+generateCCall :: Word16 -> Sequel -- stack and sequel depths
-> BCEnv
- -> CCallSpec -- where to call
- -> Id -- of target, for type info
- -> [AnnExpr' Id VarSet] -- args (atoms)
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
- = let
+ = let
-- useful constants
addr_sizeW :: Word16
addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
@@ -935,19 +931,19 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- CgRep of what was actually pushed.
pargs _ [] = return []
- pargs d (a:az)
+ pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
in case splitTyConApp_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
- Just (t, _)
- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ Just (t, _)
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
return ((code,AddrRep):rest)
- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
return ((code,AddrRep):rest)
@@ -991,18 +987,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
(returns_void, r_rep)
= case maybe_getCCallReturnRep (idType fn) of
Nothing -> (True, VoidRep)
- Just rr -> (False, rr)
+ Just rr -> (False, rr)
{-
- Because the Haskell stack grows down, the a_reps refer to
+ Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
are on the stack. Now push an unboxed Addr# indicating
- the C function to call. Then push a dummy placeholder for the
- result. Finally, emit a CCALL insn with an offset pointing to the
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
address of the piece of marshalling code we generate.
- So, just prior to the CCALL insn, the stack looks like this
+ So, just prior to the CCALL insn, the stack looks like this
(growing down, as usual):
-
+
<arg_n>
...
<arg_1>
@@ -1010,7 +1006,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
<placeholder-for-result#> (must be an unboxed type)
The interpreter then calls the marshall code mentioned
- in the CCALL insn, passing it (& <placeholder-for-result#>),
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
that is, the addr of the topmost word in the stack.
When this returns, the placeholder will have been
filled in. The placeholder is slid down to the sequel
@@ -1053,7 +1049,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
| is_static = a_reps_pushed_RAW
- | otherwise = if null a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
else tail a_reps_pushed_RAW
@@ -1062,7 +1058,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
d_after_args + addr_sizeW)
- | otherwise -- is already on the stack
+ | otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
@@ -1070,17 +1066,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
r_sizeW = fromIntegral (primRepSizeW r_rep)
d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
- push_r = (if returns_void
- then nilOL
+ push_r = (if returns_void
+ then nilOL
else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
-- generate the marshalling code we're going to call
- -- Offset of the next stack frame down the stack. The CCALL
- -- instruction needs to describe the chunk of stack containing
- -- the ccall args to the GC, so it needs to know how large it
- -- is. See comment in Interpreter.c with the CCALL instruction.
- stk_offset = d_after_r - s
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
+ stk_offset = d_after_r - s
-- in
-- the only difference in libffi mode is that we prepare a cif
@@ -1119,7 +1115,7 @@ mkDummyLiteral pr
_ -> panic "mkDummyLiteral"
--- Convert (eg)
+-- Convert (eg)
-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
@@ -1136,9 +1132,9 @@ mkDummyLiteral pr
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
= let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
- maybe_r_rep_to_go
+ maybe_r_rep_to_go
= if isSingleton r_reps then Nothing else Just (r_reps !! 1)
- (r_tycon, r_reps)
+ (r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
@@ -1148,19 +1144,19 @@ maybe_getCCallReturnRep fn_ty
&& case maybe_r_rep_to_go of
Nothing -> True
Just r_rep -> r_rep /= PtrRep
- -- if it was, it would be impossible
- -- to create a valid return value
+ -- if it was, it would be impossible
+ -- to create a valid return value
-- placeholder on the stack
blargh :: a -- Used at more than one type
- blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
- in
+ in
--trace (showSDoc (ppr (a_reps, r_reps))) $
if ok then maybe_r_rep_to_go else blargh
-- Compile code which expects an unboxed Int on the top of stack,
--- (call it i), and pushes the i'th closure in the supplied list
+-- (call it i), and pushes the i'th closure in the supplied list
-- as a consequence.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
@@ -1172,13 +1168,13 @@ implement_tagToId names
[0 ..] names
steps = map (mkStep label_exit) infos
return (concatOL steps
- `appOL`
+ `appOL`
toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
where
mkStep l_exit (my_label, next_label, n, name_for_n)
- = toOL [LABEL my_label,
- TESTEQ_I n next_label,
- PUSH_G name_for_n,
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G name_for_n,
JMP l_exit]
@@ -1197,8 +1193,8 @@ implement_tagToId names
pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
-pushAtom d p e
- | Just e' <- bcView e
+pushAtom d p e
+ | Just e' <- bcView e
= pushAtom d p e'
pushAtom d p (AnnVar v)
@@ -1214,19 +1210,19 @@ pushAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
= let l = d - d_v + sz - 2
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
- -- d - d_v the number of words between the TOS
- -- and the 1st slot of the object
- --
- -- d - d_v - 1 the offset from the TOS of the 1st slot
- --
- -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
- -- of the object.
- --
- -- Having found the last slot, we proceed to copy the right number of
- -- slots on to the top of the stack.
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
| otherwise -- v must be a global variable
- = ASSERT(sz == 1)
+ = ASSERT(sz == 1)
return (unitOL (PUSH_G (getName v)), sz)
where
@@ -1242,31 +1238,31 @@ pushAtom _ _ (AnnLit lit)
MachFloat _ -> code FloatArg
MachDouble _ -> code DoubleArg
MachChar _ -> code NonPtrArg
- MachNullAddr -> code NonPtrArg
+ MachNullAddr -> code NonPtrArg
MachStr s -> pushStr s
l -> pprPanic "pushAtom" (ppr l)
where
code rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
- in return (unitOL (PUSH_UBX (Left lit) size_host_words),
+ in return (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
- pushStr s
+ pushStr s
= let getMallocvilleAddr
= case s of
- FastString _ n _ fp _ ->
- -- we could grab the Ptr from the ForeignPtr,
- -- but then we have no way to control its lifetime.
- -- In reality it'll probably stay alive long enoungh
- -- by virtue of the global FastString table, but
- -- to be on the safe side we copy the string into
- -- a malloc'd area of memory.
+ FastString _ n _ fp _ ->
+ -- we could grab the Ptr from the ForeignPtr,
+ -- but then we have no way to control its lifetime.
+ -- In reality it'll probably stay alive long enoungh
+ -- by virtue of the global FastString table, but
+ -- to be on the safe side we copy the string into
+ -- a malloc'd area of memory.
do ptr <- ioToBc (mallocBytes (n+1))
recordMallocBc ptr
ioToBc (
withForeignPtr fp $ \p -> do
- memcpy ptr p (fromIntegral n)
- pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ memcpy ptr p (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
return ptr
)
in do
@@ -1278,7 +1274,7 @@ pushAtom d p (AnnCast e _)
= pushAtom d p (snd e)
pushAtom _ _ expr
- = pprPanic "ByteCodeGen.pushAtom"
+ = pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
foreign import ccall unsafe "memcpy"
@@ -1290,14 +1286,14 @@ foreign import ccall unsafe "memcpy"
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
-mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
- -- a hint; generates better code
- -- Nothing is always safe
- -> [(Discr, BCInstrList)]
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+ -- a hint; generates better code
+ -- Nothing is always safe
+ -> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways
= let d_way = filter (isNoDiscr.fst) raw_ways
- notd_ways = sortLe
+ notd_ways = sortLe
(\w1 w2 -> leAlt (fst w1) (fst w2))
(filter (not.isNoDiscr.fst) raw_ways)
@@ -1305,14 +1301,14 @@ mkMultiBranch maybe_ncons raw_ways
mkTree [] _range_lo _range_hi = return the_default
mkTree [val] range_lo range_hi
- | range_lo `eqAlt` range_hi
+ | range_lo `eqAlt` range_hi
= return (snd val)
| otherwise
= do label_neq <- getLabelBc
- return (testEQ (fst val) label_neq
- `consOL` (snd val
- `appOL` unitOL (LABEL label_neq)
- `appOL` the_default))
+ return (testEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
mkTree vals range_lo range_hi
= let n = length vals `div` 2
@@ -1324,11 +1320,11 @@ mkMultiBranch maybe_ncons raw_ways
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
return (testLT v_mid label_geq
- `consOL` (code_lo
- `appOL` unitOL (LABEL label_geq)
- `appOL` code_hi))
-
- the_default
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
= case d_way of [] -> unitOL CASEFAIL
[(_, def)] -> def
_ -> panic "mkMultiBranch/the_default"
@@ -1353,12 +1349,12 @@ mkMultiBranch maybe_ncons raw_ways
= panic "mkMultiBranch: awesome foursome"
| otherwise
= case fst (head notd_ways) of
- DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
- DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
- DiscrF _ -> ( DiscrF minF, DiscrF maxF )
- DiscrD _ -> ( DiscrD minD, DiscrD maxD )
- DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
- NoDiscr -> panic "mkMultiBranch NoDiscr"
+ DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrF _ -> ( DiscrF minF, DiscrF maxF )
+ DiscrD _ -> ( DiscrD minD, DiscrD maxD )
+ DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+ NoDiscr -> panic "mkMultiBranch NoDiscr"
(algMinBound, algMaxBound)
= case maybe_ncons of
@@ -1388,8 +1384,8 @@ mkMultiBranch maybe_ncons raw_ways
dec (DiscrI i) = DiscrI (i-1)
dec (DiscrW w) = DiscrW (w-1)
dec (DiscrP i) = DiscrP (i-1)
- dec other = other -- not really right, but if you
- -- do cases on floating values, you'll get what you deserve
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
-- same snotty comment applies to the following
minF, maxF :: Float
@@ -1406,7 +1402,7 @@ mkMultiBranch maybe_ncons raw_ways
-- Supporting junk for the compilation schemes
-- Describes case alts
-data Discr
+data Discr
= DiscrI Int
| DiscrW Word
| DiscrF Float
@@ -1431,9 +1427,9 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id))
-- See bug #1257
unboxedTupleException :: a
-unboxedTupleException
- = ghcError
- (ProgramError
+unboxedTupleException
+ = ghcError
+ (ProgramError
("Error: bytecode compiler can't handle unboxed tuples.\n"++
" Possibly due to foreign import/export decls in source.\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
@@ -1443,11 +1439,11 @@ mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
- -- The arguments are returned in *right-to-left* order
+ -- The arguments are returned in *right-to-left* order
splitApp e | Just e' <- bcView e = splitApp e'
-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
- (f', as) -> (f', a:as)
-splitApp e = (e, [])
+splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp e = (e, [])
bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
@@ -1456,23 +1452,23 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- b) type applications
-- c) casts
-- d) notes
--- Type lambdas *can* occur in random expressions,
+-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
-bcView (AnnNote _ (_,e)) = Just e
-bcView (AnnCast (_,e) _) = Just e
+bcView (AnnNote _ (_,e)) = Just e
+bcView (AnnCast (_,e) _) = Just e
bcView (AnnLam v (_,e)) | isTyCoVar v = Just e
-bcView (AnnApp (_,e) (_, AnnType _)) = Just e
-bcView _ = Nothing
+bcView (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView _ = Nothing
isVoidArgAtom :: AnnExpr' Var ann -> Bool
isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
-isVoidArgAtom _ = False
+isVoidArgAtom _ = False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
-atomPrimRep (AnnVar v) = typePrimRep (idType v)
-atomPrimRep (AnnLit l) = typePrimRep (literalType l)
+atomPrimRep (AnnVar v) = typePrimRep (idType v)
+atomPrimRep (AnnLit l) = typePrimRep (literalType l)
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
atomRep :: AnnExpr' Id ann -> CgRep
@@ -1493,32 +1489,32 @@ mkStackOffsets original_depth szsw
type BcPtr = Either ItblPtr (Ptr ())
-data BcM_State
- = BcM_State {
+data BcM_State
+ = BcM_State {
uniqSupply :: UniqSupply, -- for generating fresh variable names
- nextlabel :: Word16, -- for generating local labels
- malloced :: [BcPtr], -- thunks malloced for current BCO
- -- Should be free()d when it is GCd
- breakArray :: BreakArray -- array of breakpoint flags
+ nextlabel :: Word16, -- for generating local labels
+ malloced :: [BcPtr], -- thunks malloced for current BCO
+ -- Should be free()d when it is GCd
+ breakArray :: BreakArray -- array of breakpoint flags
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
ioToBc :: IO a -> BcM a
-ioToBc io = BcM $ \st -> do
- x <- io
+ioToBc io = BcM $ \st -> do
+ x <- io
return (st, x)
runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us modBreaks (BcM m)
- = m (BcM_State us 0 [] breakArray)
+runBc us modBreaks (BcM m)
+ = m (BcM_State us 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
(st1, q) <- expr st0
- let BcM k = cont q
+ let BcM k = cont q
(st2, r) <- k st1
return (st2, r)
@@ -1557,10 +1553,10 @@ getLabelBc
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
- = BcM $ \st -> let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
-getBreakArray :: BcM BreakArray
+getBreakArray :: BcM BreakArray
getBreakArray = BcM $ \st -> return (st, breakArray st)
newUnique :: BcM Unique
@@ -1570,7 +1566,7 @@ newUnique = BcM $
in return (newState, uniq)
newId :: Type -> BcM Id
-newId ty = do
+newId ty = do
uniq <- newUnique
return $ mkSysLocal tickFS uniq ty
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 67515e53a1..372bd3507e 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -233,5 +233,5 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
errorsToGhcException :: [Located String] -> GhcException
errorsToGhcException errs =
let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
- in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
+ in UsageError (renderWithStyle errors cmdlineParserStyle)
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index a832034749..2719470aaa 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -51,12 +51,10 @@ import SrcLoc
import FastString
import LlvmCodeGen ( llvmFixupAsm )
import MonadUtils
+import Platform
--- import Data.Either
import Exception
import Data.IORef ( readIORef )
-import Distribution.System
--- import GHC.Exts ( Int(..) )
import System.Directory
import System.FilePath
import System.IO
@@ -1061,7 +1059,7 @@ runPhase cc_phase input_fn dflags
-- than a double, which leads to unpredictable results.
-- By default, we turn this off with -ffloat-store unless
-- the user specified -fexcess-precision.
- (if cTargetArch == I386 &&
+ (if platformArch (targetPlatform dflags) == ArchX86 &&
not (dopt Opt_ExcessPrecision dflags)
then [ "-ffloat-store" ]
else []) ++
@@ -1093,7 +1091,7 @@ runPhase cc_phase input_fn dflags
-- These symbols are imported into the stub.c file via RtsAPI.h, and the
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
- ++ (if cTargetOS == Windows &&
+ ++ (if platformOS (targetPlatform dflags) == OSMinGW32 &&
thisPackage dflags == basePackageId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
@@ -1104,7 +1102,7 @@ runPhase cc_phase input_fn dflags
-- regardless of the ordering.
--
-- This is a temporary hack.
- ++ (if cTargetArch == Sparc
+ ++ (if platformArch (targetPlatform dflags) == ArchSPARC
then ["-mcpu=v9"]
else [])
@@ -1182,7 +1180,7 @@ runPhase As input_fn dflags
-- regardless of the ordering.
--
-- This is a temporary hack.
- ++ (if cTargetArch == Sparc
+ ++ (if platformArch (targetPlatform dflags) == ArchSPARC
then [SysTools.Option "-mcpu=v9"]
else [])
@@ -1237,7 +1235,7 @@ runPhase SplitAs _input_fn dflags
-- regardless of the ordering.
--
-- This is a temporary hack.
- (if cTargetArch == Sparc
+ (if platformArch (targetPlatform dflags) == ArchSPARC
then [SysTools.Option "-mcpu=v9"]
else []) ++
@@ -1330,7 +1328,7 @@ runPhase LlvmLlc input_fn dflags
return (LlvmMangle, output_fn)
where
-- Bug in LLVM at O3 on OSX.
- llvmOpts = if cTargetOS == OSX
+ llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
then ["-O1", "-O2", "-O2"]
else ["-O1", "-O2", "-O3"]
@@ -1647,7 +1645,7 @@ linkBinary dflags o_files dep_packages = do
-- Permit the linker to auto link _symbol to _imp_symbol.
-- This lets us link against DLLs without needing an "import library".
- ++ (if cTargetOS == Windows
+ ++ (if platformOS (targetPlatform dflags) == OSMinGW32
then ["-Wl,--enable-auto-import"]
else [])
@@ -1681,13 +1679,13 @@ linkBinary dflags o_files dep_packages = do
exeFileName :: DynFlags -> FilePath
exeFileName dflags
| Just s <- outputFile dflags =
- if cTargetOS == Windows
+ if platformOS (targetPlatform dflags) == OSMinGW32
then if null (takeExtension s)
then s <.> "exe"
else s
else s
| otherwise =
- if cTargetOS == Windows
+ if platformOS (targetPlatform dflags) == OSMinGW32
then "main.exe"
else "a.out"
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 873b846d0e..488cf86c10 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -108,7 +108,6 @@ import Data.Char
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
-import Distribution.System
import System.FilePath
import System.IO ( stderr, hPutChar )
@@ -807,12 +806,12 @@ defaultDynFlags mySettings =
log_action = \severity srcSpan style msg ->
case severity of
- SevOutput -> printOutput (msg style)
- SevInfo -> printErrs (msg style)
- SevFatal -> printErrs (msg style)
+ SevOutput -> printSDoc msg style
+ SevInfo -> printErrs msg style
+ SevFatal -> printErrs msg style
_ -> do
hPutChar stderr '\n'
- printErrs ((mkLocMessage srcSpan msg) style)
+ printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
@@ -1104,18 +1103,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do
= runCmdLine (processArgs flag_spec args') dflags0
when (not (null errs)) $ ghcError $ errorsToGhcException errs
- let (pic_warns, dflags2)
- | not (cTargetArch == X86_64 && (cTargetOS == Linux || cTargetOS == OSX)) &&
- (not opt_Static || opt_PIC) &&
- hscTarget dflags1 == HscLlvm
- = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and "
- ++ "-dynamic on this platform;\n"
- ++ " using "
- ++ showHscTargetFlag defaultObjectTarget ++ " instead"],
- dflags1{ hscTarget = defaultObjectTarget })
- | otherwise = ([], dflags1)
-
- return (dflags2, leftover, pic_warns ++ warns)
+ return (dflags1, leftover, warns)
{- **********************************************************************
@@ -2055,21 +2043,28 @@ setObjTarget l = updM set
= case l of
HscC
| cGhcUnregisterised /= "YES" ->
- do addWarn ("Compiler not unregisterised, so ignoring " ++
- showHscTargetFlag l)
+ do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
return dflags
HscAsm
| cGhcWithNativeCodeGen /= "YES" ->
do addWarn ("Compiler has no native codegen, so ignoring " ++
- showHscTargetFlag l)
+ flag)
return dflags
HscLlvm
| cGhcUnregisterised == "YES" ->
- do addWarn ("Compiler unregisterised, so ignoring " ++
- showHscTargetFlag l)
+ do addWarn ("Compiler unregisterised, so ignoring " ++ flag)
+ return dflags
+ | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
+ (not opt_Static || opt_PIC)
+ ->
+ do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
return dflags
_ -> return $ dflags { hscTarget = l }
| otherwise = return dflags
+ where platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
+ flag = showHscTargetFlag l
setOptLevel :: Int -> DynFlags -> DynP DynFlags
setOptLevel n dflags
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d0a8a862a4..b6297a2d6d 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -67,7 +67,8 @@ mkLocMessage locn msg
-- would look strange. Better to say explicitly "<no location info>".
printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+ printErrs (mkLocMessage span msg) defaultErrStyle
-- -----------------------------------------------------------------------------
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 27858dc847..07acbbbbec 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -86,7 +86,6 @@ import Data.List
import Data.Maybe
import Control.Monad
import System.IO
-import Distribution.System
{-
The native-code generator has machine-independent and
@@ -485,7 +484,7 @@ makeImportsDoc dflags imports
| otherwise
= Pretty.empty
- doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
astyle = mkCodeStyle AsmStyle
@@ -823,8 +822,10 @@ cmmStmtConFold stmt
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
- = case expr of
+cmmExprConFold referenceKind expr = do
+ dflags <- getDynFlagsCmmOpt
+ let arch = platformArch (targetPlatform dflags)
+ case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
@@ -837,11 +838,9 @@ cmmExprConFold referenceKind expr
CmmLit (CmmLabel lbl)
-> do
- dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
@@ -852,15 +851,15 @@ cmmExprConFold referenceKind expr
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 44a6a7ce46..8d8b16a0a5 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -12,7 +12,6 @@ module PPC.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
@@ -157,9 +156,6 @@ instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
pprReg :: Reg -> Doc
pprReg r
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 0139680dcc..c5a33141d5 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -12,7 +12,6 @@ module SPARC.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem
@@ -141,12 +140,6 @@ instance Outputable Instr where
-- | Pretty print a register.
--- This is an alias of pprReg for legacy reasons, should remove it.
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
-
--- | Pretty print a register.
pprReg :: Reg -> Doc
pprReg reg
= case reg of
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 4c3454d43b..a9ed03610e 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -12,7 +12,6 @@ module X86.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
@@ -34,7 +33,6 @@ import PprBase
import OldCmm
import CLabel
-import Config
import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
@@ -42,7 +40,6 @@ import qualified Outputable
import Outputable (panic, Outputable)
import Data.Word
-import Distribution.System
#if i386_TARGET_ARCH && darwin_TARGET_OS
import Data.Bits
@@ -172,12 +169,6 @@ instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg
- | cTargetArch == I386 = pprReg II32
- | cTargetArch == X86_64 = pprReg II64
- | otherwise = panic "X86.Ppr.pprUserReg: not defined"
-
pprReg :: Size -> Reg -> Doc
pprReg s r
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 826c09b996..bd48872c05 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1147,7 +1147,7 @@ failIfM :: Message -> IfL a
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
- ; liftIO (printErrs (full_msg defaultErrStyle))
+ ; liftIO (printErrs full_msg defaultErrStyle)
; failM }
--------------------
@@ -1182,7 +1182,7 @@ forkM_maybe doc thing_inside
; return Nothing }
}}
where
- print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+ print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index c4a685b3b5..fc4d919473 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -15,7 +15,7 @@ module Outputable (
Outputable(..), OutputableBndr(..),
-- * Pretty printing combinators
- SDoc,
+ SDoc, runSDoc, initSDocContext,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
@@ -33,6 +33,9 @@ module Outputable (
hang, punctuate, ppWhen, ppUnless,
speakNth, speakNTimes, speakN, speakNOf, plural,
+ coloured, PprColour, colType, colCoerc, colDataCon,
+ colBinder, bold, keyword,
+
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printErrs, printOutput, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
@@ -41,6 +44,7 @@ module Outputable (
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showPpr,
showSDocUnqual, showsPrecSDoc,
+ renderWithStyle,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
@@ -218,38 +222,56 @@ code (either C or assembly), or generating interface files.
%************************************************************************
\begin{code}
-type SDoc = PprStyle -> Doc
+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+
+data SDocContext = SDC
+ { sdocStyle :: !PprStyle
+ , sdocLastColour :: !PprColour
+ -- ^ The most recently used colour. This allows nesting colours.
+ }
+
+initSDocContext :: PprStyle -> SDocContext
+initSDocContext sty = SDC
+ { sdocStyle = sty
+ , sdocLastColour = colReset
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
pprDeeper :: SDoc -> SDoc
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty = d other_sty
+pprDeeper d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
+ SDC{sdocStyle=PprUser q (PartWay n)} ->
+ runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ _ -> runSDoc d ctx
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds (PprUser q (PartWay n))
- | n==0 = Pretty.text "..."
- | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
- where
- go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
-
-pprDeeperList f ds other_sty
- = f ds other_sty
+pprDeeperList f ds = SDoc work
+ where
+ work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
+ | n==0 = Pretty.text "..."
+ | otherwise =
+ runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ where
+ go _ [] = []
+ go i (d:ds) | i >= n = [text "...."]
+ | otherwise = d : go (i+1) ds
+ work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
-pprSetDepth _depth doc other_sty = doc other_sty
+pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser q _} ->
+ runSDoc doc ctx{sdocStyle = PprUser q depth}
+ _ ->
+ runSDoc doc ctx
getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
+getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
\end{code}
\begin{code}
@@ -282,22 +304,24 @@ userStyle (PprUser _ _) = True
userStyle _other = False
ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _ = Pretty.empty
+ifPprDebug d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprDebug} -> runSDoc d ctx
+ _ -> Pretty.empty
\end{code}
\begin{code}
-- Unused [7/02 sof]
printSDoc :: SDoc -> PprStyle -> IO ()
printSDoc d sty = do
- Pretty.printDoc PageMode stdout (d sty)
+ Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
hFlush stdout
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
- hFlush stderr
+printErrs :: SDoc -> PprStyle -> IO ()
+printErrs doc sty = do
+ Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
+ hFlush stderr
printOutput :: Doc -> IO ()
printOutput doc = Pretty.printDoc PageMode stdout doc
@@ -307,25 +331,32 @@ printDump doc = hPrintDump stdout doc
hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
- Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+ Pretty.printDoc PageMode h
+ (runSDoc better_doc (initSDocContext defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode CStyle)))
printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode AsmStyle)))
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
@@ -337,32 +368,44 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
+
+renderWithStyle :: SDoc -> PprStyle -> String
+renderWithStyle sdoc sty =
+ Pretty.render (runSDoc sdoc (initSDocContext sty))
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc =
+ show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
showSDocUnqual :: SDoc -> String
-- Only used in the gruesome isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d =
+ show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
showSDocDump :: SDoc -> String
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d =
+ Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d =
+ Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
@@ -370,7 +413,7 @@ showPpr = showSDoc . ppr
\begin{code}
docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
+docToSDoc d = SDoc (\_ -> d)
empty :: SDoc
char :: Char -> SDoc
@@ -383,58 +426,58 @@ float :: Float -> SDoc
double :: Double -> SDoc
rational :: Rational -> SDoc
-empty _sty = Pretty.empty
-char c _sty = Pretty.char c
-text s _sty = Pretty.text s
-ftext s _sty = Pretty.ftext s
-ptext s _sty = Pretty.ptext s
-int n _sty = Pretty.int n
-integer n _sty = Pretty.integer n
-float n _sty = Pretty.float n
-double n _sty = Pretty.double n
-rational n _sty = Pretty.rational n
+empty = docToSDoc $ Pretty.empty
+char c = docToSDoc $ Pretty.char c
+text s = docToSDoc $ Pretty.text s
+ftext s = docToSDoc $ Pretty.ftext s
+ptext s = docToSDoc $ Pretty.ptext s
+int n = docToSDoc $ Pretty.int n
+integer n = docToSDoc $ Pretty.integer n
+float n = docToSDoc $ Pretty.float n
+double n = docToSDoc $ Pretty.double n
+rational n = docToSDoc $ Pretty.rational n
parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
-parens d sty = Pretty.parens (d sty)
-braces d sty = Pretty.braces (d sty)
-brackets d sty = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d = char '<' <> d <> char '>'
+parens d = SDoc $ Pretty.parens . runSDoc d
+braces d = SDoc $ Pretty.braces . runSDoc d
+brackets d = SDoc $ Pretty.brackets . runSDoc d
+doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+angleBrackets d = char '<' <> d <> char '>'
cparen :: Bool -> SDoc -> SDoc
-cparen b d sty = Pretty.cparen b (d sty)
+cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-- quotes encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
-quotes d sty = case show pp_d of
- ('\'' : _) -> pp_d
- _other -> Pretty.quotes pp_d
- where
- pp_d = d sty
+quotes d = SDoc $ \sty ->
+ let pp_d = runSDoc d sty in
+ case show pp_d of
+ ('\'' : _) -> pp_d
+ _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
-blankLine _sty = Pretty.ptext (sLit "")
-dcolon _sty = Pretty.ptext (sLit "::")
-arrow _sty = Pretty.ptext (sLit "->")
-darrow _sty = Pretty.ptext (sLit "=>")
-semi _sty = Pretty.semi
-comma _sty = Pretty.comma
-colon _sty = Pretty.colon
-equals _sty = Pretty.equals
-space _sty = Pretty.space
-underscore = char '_'
-dot = char '.'
-lparen _sty = Pretty.lparen
-rparen _sty = Pretty.rparen
-lbrack _sty = Pretty.lbrack
-rbrack _sty = Pretty.rbrack
-lbrace _sty = Pretty.lbrace
-rbrace _sty = Pretty.rbrace
+blankLine = docToSDoc $ Pretty.ptext (sLit "")
+dcolon = docToSDoc $ Pretty.ptext (sLit "::")
+arrow = docToSDoc $ Pretty.ptext (sLit "->")
+darrow = docToSDoc $ Pretty.ptext (sLit "=>")
+semi = docToSDoc $ Pretty.semi
+comma = docToSDoc $ Pretty.comma
+colon = docToSDoc $ Pretty.colon
+equals = docToSDoc $ Pretty.equals
+space = docToSDoc $ Pretty.space
+underscore = char '_'
+dot = char '.'
+lparen = docToSDoc $ Pretty.lparen
+rparen = docToSDoc $ Pretty.rparen
+lbrack = docToSDoc $ Pretty.lbrack
+rbrack = docToSDoc $ Pretty.rbrack
+lbrace = docToSDoc $ Pretty.lbrace
+rbrace = docToSDoc $ Pretty.rbrace
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
@@ -448,11 +491,11 @@ nest :: Int -> SDoc -> SDoc
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
-nest n d sty = Pretty.nest n (d sty)
-(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+nest n d = SDoc $ Pretty.nest n . runSDoc d
+(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
+($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
@@ -471,19 +514,19 @@ fcat :: [SDoc] -> SDoc
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty = Pretty.sep [d sty | d <- ds]
-cat ds sty = Pretty.cat [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
+hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
+cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
hang :: SDoc -- ^ The header
-> Int -- ^ Amount to indent the hung body
-> SDoc -- ^ The hung body, indented and placed below the header
-> SDoc
-hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
+hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
punctuate :: SDoc -- ^ The punctuation
-> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
@@ -500,6 +543,46 @@ ppWhen False _ = empty
ppUnless True _ = empty
ppUnless False doc = doc
+
+-- | A colour\/style for use with 'coloured'.
+newtype PprColour = PprColour String
+
+-- Colours
+
+colType :: PprColour
+colType = PprColour "\27[34m"
+
+colBold :: PprColour
+colBold = PprColour "\27[;1m"
+
+colCoerc :: PprColour
+colCoerc = PprColour "\27[34m"
+
+colDataCon :: PprColour
+colDataCon = PprColour "\27[31m"
+
+colBinder :: PprColour
+colBinder = PprColour "\27[32m"
+
+colReset :: PprColour
+colReset = PprColour "\27[0m"
+
+-- | Apply the given colour\/style for the argument.
+--
+-- Only takes effect if colours are enabled.
+coloured :: PprColour -> SDoc -> SDoc
+-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+coloured col@(PprColour c) sdoc =
+ SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+ let ctx' = ctx{ sdocLastColour = col } in
+ Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+
+bold :: SDoc -> SDoc
+bold = coloured colBold
+
+keyword :: SDoc -> SDoc
+keyword = bold
+
\end{code}
@@ -806,21 +889,23 @@ pprDefiniteTrace str doc x = pprAndThen trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
+pprPanicFastInt heading pretty_msg =
+ panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+ doc = text heading <+> pretty_msg
pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
- where
+pprAndThen cont heading pretty_msg =
+ cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
doc = sep [text heading, nest 4 pretty_msg]
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
- = panic (show (doc PprDebug))
+ = panic (show (runSDoc doc (initSDocContext PprDebug)))
where
doc = sep [hsep[text "ASSERT failed! file",
text file,
@@ -833,7 +918,7 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
- = trace (show (doc defaultDumpStyle)) x
+ = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
where
doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
msg]
diff --git a/compiler/nativeGen/Platform.hs b/compiler/utils/Platform.hs
index 7b2502d96e..7b2502d96e 100644
--- a/compiler/nativeGen/Platform.hs
+++ b/compiler/utils/Platform.hs
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index a518c0b6f6..f0ca69cbb9 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -163,7 +163,7 @@ module Pretty (
empty, isEmpty, nest,
- char, text, ftext, ptext,
+ char, text, ftext, ptext, zeroWidthText,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
@@ -224,6 +224,10 @@ The primitive @Doc@ values
\begin{code}
empty :: Doc
isEmpty :: Doc -> Bool
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags
+zeroWidthText :: String -> Doc
+
text :: String -> Doc
char :: Char -> Doc
@@ -560,6 +564,7 @@ ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
ptext :: LitString -> Doc
ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
where s = {-castPtr-} s_
+zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
#if defined(__GLASGOW_HASKELL__)
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
View Lorry Controller Status