From: Jose Pedro Magalhaes Date: Mon, 9 May 2011 12:04:37 +0000 (+0200) Subject: Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=61d89bc49eb75d74ed9196ba5f7b7b32018b914b;hp=c7cb47fc0e98e660621bfe7368464c4c93c9dbf1 Merge branch 'master' of darcs.haskell.org/ghc into ghc-generics --- diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 03f541e..89b3edd 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 1c7e7e5..a2eecd5 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 10f4e8b..aa7d914 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 55ebb84..2254332 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 2c7473b..af9fbe9 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 f34ac9c..b888747 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 var1 ... varN of DEFAULT -> e @@ -535,7 +531,7 @@ schemeE _ _ _ expr otherwise we return Nothing. - The idea is that the "case tick ..." is really just an annotation on + The idea is that the "case tick ..." 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): - + ... @@ -1010,7 +1006,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l (must be an unboxed type) The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), + in the CCALL insn, passing it (& ), 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 67515e5..372bd35 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 a832034..2719470 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 873b846..488cf86 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 d0a8a86..b6297a2 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 "". 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 27858dc..07acbbb 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 44a6a7c..8d8b16a 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 0139680..c5a3314 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 4c3454d..a9ed036 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 826c09b..bd48872 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 c4a685b..fc4d919 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 similarity index 100% rename from compiler/nativeGen/Platform.hs rename to compiler/utils/Platform.hs diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index a518c0b..f0ca69c 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 diff --git a/configure.ac b/configure.ac index 67d6b57..2de4d8a 100644 --- a/configure.ac +++ b/configure.ac @@ -242,7 +242,6 @@ case $host in ;; esac -# Sync this with cTargetArch in compiler/ghc.mk checkArch() { case $1 in alpha|arm|hppa|hppa1_1|i386|ia64|m68k|mips|mipseb|mipsel|powerpc|powerpc64|rs6000|s390|sparc|sparc64|vax|x86_64) @@ -265,7 +264,6 @@ checkVendor() { esac } -# Sync this with cTargetOS in compiler/ghc.mk checkOS() { case $1 in linux|freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 2685377..0f68607 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -38,7 +38,7 @@ import HscTypes ( handleFlagWarnings ) import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import RdrName (RdrName) -import Outputable hiding (printForUser, printForUserPartWay) +import Outputable hiding (printForUser, printForUserPartWay, bold) import Module -- for ModuleEnv import Name import SrcLoc diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index f7fbd32..9bd707f 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -812,7 +812,7 @@ dumpCensus( Census *census ) rs->id = -(rs->id); // report in the unit of bytes: * sizeof(StgWord) - printRetainerSetShort(hp_file, rs); + printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength); break; } default: diff --git a/rts/RetainerSet.c b/rts/RetainerSet.c index 5e9b37c..d93ae4b 100644 --- a/rts/RetainerSet.c +++ b/rts/RetainerSet.c @@ -265,35 +265,34 @@ printRetainer(FILE *f, retainer cc) #if defined(RETAINER_SCHEME_INFO) // Retainer scheme 1: retainer = info table void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); // size = strlen(tmp); } } @@ -302,10 +301,9 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; @@ -313,35 +311,34 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CCS) // Retainer scheme 2: retainer = cost centre stack void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; - int size; + char tmp[max_length + 1]; + nat size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); // size = strlen(tmp); } } @@ -350,46 +347,44 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre static void -printRetainerSetShort(FILE *f, retainerSet *rs) +printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); // size = strlen(tmp); } } fprintf(f, tmp); /* - #define MAX_RETAINER_SET_SPACE 24 #define DOT_NUMBER 3 - // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0') - // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for + // 1. 32 > max_length + 1 (1 for '\0') + // 2. (max_length - DOT_NUMBER ) characters should be enough for // printing one natural number (plus '(' and ')'). char tmp[32]; int size, ts; @@ -400,12 +395,12 @@ printRetainerSetShort(FILE *f, retainerSet *rs) // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER); + ASSERT(size < max_length - DOT_NUMBER); for (j = 0; j < rs->num; j++) { ts = strlen(rs->element[j]->label); if (j < rs->num - 1) { - if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts + 1 > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } @@ -413,7 +408,7 @@ printRetainerSetShort(FILE *f, retainerSet *rs) size += ts + 1; } else { - if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } diff --git a/rts/RetainerSet.h b/rts/RetainerSet.h index 74152b9..5004527 100644 --- a/rts/RetainerSet.h +++ b/rts/RetainerSet.h @@ -165,7 +165,7 @@ void traverseAllRetainerSet(void (*f)(RetainerSet *)); #ifdef SECOND_APPROACH // Prints a single retainer set. -void printRetainerSetShort(FILE *, RetainerSet *); +void printRetainerSetShort(FILE *, RetainerSet *, nat); #endif // Print the statistics on all the retainer sets. diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index a7dc918..2497e29 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -64,17 +64,17 @@ ifeq "$3" "dyn" # On windows we have to supply the extra libs this one links to when building it. ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32" $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) - "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ + "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \ -shared -dynamic -dynload deploy \ $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \ - -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ + -no-auto-link-packages \ -o $$@ else $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) - "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ + "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \ -shared -dynamic -dynload deploy \ -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \ - -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ + -no-auto-link-packages \ -o $$@ endif else