diff --git a/compiler/Bytecodes.h b/compiler/Bytecodes.h --- a/compiler/Bytecodes.h +++ b/compiler/Bytecodes.h @@ -34,7 +34,6 @@ #define bci_PUSH16_W 9 #define bci_PUSH32_W 10 #define bci_PUSH_G 11 -#define bci_PUSH_ALTS 12 #define bci_PUSH_ALTS_P 13 #define bci_PUSH_ALTS_N 14 #define bci_PUSH_ALTS_F 15 @@ -81,7 +80,6 @@ #define bci_CCALL 56 #define bci_SWIZZLE 57 #define bci_ENTER 58 -#define bci_RETURN 59 #define bci_RETURN_P 60 #define bci_RETURN_N 61 #define bci_RETURN_F 62 @@ -94,6 +92,26 @@ #define bci_RETURN_T 69 #define bci_PUSH_ALTS_T 70 + +#define bci_TESTLT_I64 71 +#define bci_TESTEQ_I64 72 +#define bci_TESTLT_I32 73 +#define bci_TESTEQ_I32 74 +#define bci_TESTLT_I16 75 +#define bci_TESTEQ_I16 76 +#define bci_TESTLT_I8 77 +#define bci_TESTEQ_I8 78 +#define bci_TESTLT_W64 79 +#define bci_TESTEQ_W64 80 +#define bci_TESTLT_W32 81 +#define bci_TESTEQ_W32 82 +#define bci_TESTLT_W16 83 +#define bci_TESTEQ_W16 84 +#define bci_TESTLT_W8 85 +#define bci_TESTEQ_W8 86 + +#define bci_PRIMCALL 87 + /* If you need to go past 255 then you will run into the flags */ /* If you need to go below 0x0100 then you will run into the instructions */ diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -12,7 +12,7 @@ bcoFreeNames, SizedSeq, sizeSS, ssElts, iNTERP_STACK_CHECK_THRESH, - mkTupleInfoLit + mkNativeCallInfoLit ) where import GHC.Prelude @@ -32,7 +32,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Core.TyCon import GHC.Data.FastString @@ -40,7 +39,7 @@ import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Cmm.Expr -import GHC.Cmm.CallConv ( tupleRegsCover ) +import GHC.Cmm.CallConv ( allArgRegsCover ) import GHC.Platform import GHC.Platform.Profile @@ -98,7 +97,7 @@ -> Profile -> [ProtoBCO Name] -> [TyCon] - -> [RemotePtr ()] + -> AddrEnv -> Maybe ModBreaks -> IO CompiledByteCode assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do @@ -106,27 +105,40 @@ -- fixed for an interpreter itblenv <- mkITbls interp profile tycons bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos - (bcos',ptrs) <- mallocStrings interp bcos + bcos' <- mallocStrings interp bcos return CompiledByteCode { bc_bcos = bcos' , bc_itbls = itblenv , bc_ffis = concatMap protoBCOFFIs proto_bcos - , bc_strs = top_strs ++ ptrs + , bc_strs = top_strs , bc_breaks = modbreaks } --- Find all the literal strings and malloc them together. We want to --- do this because: +-- Note [Allocating string literals] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Our strategy for handling top-level string literal bindings is described in +-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode, +-- but not all Addr# literals in a program are guaranteed to be lifted to the +-- top level. Our strategy for handling local Addr# literals is somewhat simpler: +-- after assembling, we find all the BCONPtrStr arguments in the program, malloc +-- memory for them, and bake the resulting addresses into the instruction stream +-- in the form of BCONPtrWord arguments. -- --- a) It should be done when we compile the module, not each time we relink it --- b) For -fexternal-interpreter It's more efficient to malloc the strings --- as a single batch message, especially when compiling in parallel. +-- Since we do this when assembling, we only allocate the memory when we compile +-- the module, not each time we relink it. However, we do want to take care to +-- malloc the memory all in one go, since that is more efficient with +-- -fexternal-interpreter, especially when compiling in parallel. -- -mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()]) +-- Note that, as with top-level string literal bindings, this memory is never +-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for +-- top-level string literal bindings] in GHC.StgToByteCode for some discussion +-- about why. +-- +mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO] mallocStrings interp ulbcos = do let bytestrings = reverse (execState (mapM_ collect ulbcos) []) ptrs <- interpCmd interp (MallocStrings bytestrings) - return (evalState (mapM splice ulbcos) ptrs, ptrs) + return (evalState (mapM splice ulbcos) ptrs) where splice bco@UnlinkedBCO{..} = do lits <- mapM spliceLit unlinkedBCOLits @@ -163,7 +175,7 @@ -- TODO: the profile should be bundled with the interpreter: the rts ways are -- fixed for an interpreter ubco <- assembleBCO (profilePlatform profile) pbco - ([ubco'], _ptrs) <- mallocStrings interp [ubco] + [ubco'] <- mallocStrings interp [ubco] return ubco' assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO @@ -202,7 +214,8 @@ (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm -- precomputed size should be equal to final size - massert (n_insns == sizeSS final_insns) + massertPpr (n_insns == sizeSS final_insns) + (text "bytecode instruction count mismatch") let asm_insns = ssElts final_insns insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns @@ -351,7 +364,9 @@ fromIntegral (w `shiftR` 32), fromIntegral (w `shiftR` 16), fromIntegral w] - PW4 -> [fromIntegral (w `shiftR` 16), + PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32)) + (text "largeArg too big:" <+> ppr w) $ + [fromIntegral (w `shiftR` 16), fromIntegral w] largeArg16s :: Platform -> Word @@ -380,21 +395,18 @@ PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit bci_PUSH_G [Op p] - PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_ALTS [Op p] - PUSH_ALTS_UNLIFTED proto pk + PUSH_ALTS proto pk -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit (push_alts pk) [Op p] - PUSH_ALTS_TUPLE proto tuple_info tuple_proto + PUSH_ALTS_TUPLE proto call_info tuple_proto -> do let ul_bco = assembleBCO platform proto ul_tuple_bco = assembleBCO platform tuple_proto p <- ioptr (liftM BCOPtrBCO ul_bco) p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco) info <- int (fromIntegral $ - mkTupleInfoSig platform tuple_info) + mkNativeCallInfoSig platform call_info) emit bci_PUSH_ALTS_T [Op p, Op info, Op p_tup] PUSH_PAD8 -> emit bci_PUSH_PAD8 [] @@ -409,6 +421,10 @@ PUSH_UBX lit nws -> do np <- literal lit emit bci_PUSH_UBX [Op np, SmallOp nws] + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode + PUSH_ADDR nm -> do np <- lit [BCONPtrAddr nm] + emit bci_PUSH_UBX [Op np, SmallOp 1] + PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] @@ -439,6 +455,38 @@ emit bci_TESTLT_W [Op np, LabelOp l] TESTEQ_W w l -> do np <- word w emit bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_I64 i l -> do np <- int64 i + emit bci_TESTLT_I64 [Op np, LabelOp l] + TESTEQ_I64 i l -> do np <- int64 i + emit bci_TESTEQ_I64 [Op np, LabelOp l] + TESTLT_I32 i l -> do np <- int (fromIntegral i) + emit bci_TESTLT_I32 [Op np, LabelOp l] + TESTEQ_I32 i l -> do np <- int (fromIntegral i) + emit bci_TESTEQ_I32 [Op np, LabelOp l] + TESTLT_I16 i l -> do np <- int (fromIntegral i) + emit bci_TESTLT_I16 [Op np, LabelOp l] + TESTEQ_I16 i l -> do np <- int (fromIntegral i) + emit bci_TESTEQ_I16 [Op np, LabelOp l] + TESTLT_I8 i l -> do np <- int (fromIntegral i) + emit bci_TESTLT_I8 [Op np, LabelOp l] + TESTEQ_I8 i l -> do np <- int (fromIntegral i) + emit bci_TESTEQ_I8 [Op np, LabelOp l] + TESTLT_W64 w l -> do np <- word64 w + emit bci_TESTLT_W64 [Op np, LabelOp l] + TESTEQ_W64 w l -> do np <- word64 w + emit bci_TESTEQ_W64 [Op np, LabelOp l] + TESTLT_W32 w l -> do np <- word (fromIntegral w) + emit bci_TESTLT_W32 [Op np, LabelOp l] + TESTEQ_W32 w l -> do np <- word (fromIntegral w) + emit bci_TESTEQ_W32 [Op np, LabelOp l] + TESTLT_W16 w l -> do np <- word (fromIntegral w) + emit bci_TESTLT_W16 [Op np, LabelOp l] + TESTEQ_W16 w l -> do np <- word (fromIntegral w) + emit bci_TESTEQ_W16 [Op np, LabelOp l] + TESTLT_W8 w l -> do np <- word (fromIntegral w) + emit bci_TESTLT_W8 [Op np, LabelOp l] + TESTEQ_W8 w l -> do np <- word (fromIntegral w) + emit bci_TESTEQ_W8 [Op np, LabelOp l] TESTLT_F f l -> do np <- float f emit bci_TESTLT_F [Op np, LabelOp l] TESTEQ_F f l -> do np <- float f @@ -453,11 +501,11 @@ SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] JMP l -> emit bci_JMP [LabelOp l] ENTER -> emit bci_ENTER [] - RETURN -> emit bci_RETURN [] - RETURN_UNLIFTED rep -> emit (return_unlifted rep) [] + RETURN rep -> emit (return_non_tuple rep) [] RETURN_TUPLE -> emit bci_RETURN_T [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i] + PRIMCALL -> emit bci_PRIMCALL [] BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray q <- int (getKey uniq) np <- addr cc @@ -504,6 +552,7 @@ int16 = words . mkLitI64 platform int32 = words . mkLitI64 platform int64 = words . mkLitI64 platform + word64 = words . mkLitW64 platform words ws = lit (map BCONPtrWord ws) word w = words [w] @@ -521,16 +570,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_unlifted :: ArgRep -> Word16 -return_unlifted V = bci_RETURN_V -return_unlifted P = bci_RETURN_P -return_unlifted N = bci_RETURN_N -return_unlifted L = bci_RETURN_L -return_unlifted F = bci_RETURN_F -return_unlifted D = bci_RETURN_D -return_unlifted V16 = error "return_unlifted: vector" -return_unlifted V32 = error "return_unlifted: vector" -return_unlifted V64 = error "return_unlifted: vector" +return_non_tuple :: ArgRep -> Word16 +return_non_tuple V = bci_RETURN_V +return_non_tuple P = bci_RETURN_P +return_non_tuple N = bci_RETURN_N +return_non_tuple L = bci_RETURN_L +return_non_tuple F = bci_RETURN_F +return_non_tuple D = bci_RETURN_D +return_non_tuple V16 = error "return_non_tuple: vector" +return_non_tuple V32 = error "return_non_tuple: vector" +return_non_tuple V64 = error "return_non_tuple: vector" {- we can only handle up to a fixed number of words on the stack, @@ -546,41 +595,44 @@ maximum number of tuple elements may be larger. Elements can also take multiple words on the stack (for example Double# on a 32 bit platform). - -} -maxTupleNativeStackSize :: WordOff -maxTupleNativeStackSize = 62 +maxTupleReturnNativeStackSize :: WordOff +maxTupleReturnNativeStackSize = 62 {- - Construct the tuple_info word that stg_ctoi_t and stg_ret_t use - to convert a tuple between the native calling convention and the + Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall + use to convert arguments between the native calling convention and the interpreter. - See Note [GHCi tuple layout] for more information. + See Note [GHCi and native call registers] for more information. -} -mkTupleInfoSig :: Platform -> TupleInfo -> Word32 -mkTupleInfoSig platform TupleInfo{..} - | tupleNativeStackSize > maxTupleNativeStackSize - = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler" - (ppr tupleNativeStackSize <+> text "stack words." <+> +mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32 +mkNativeCallInfoSig platform NativeCallInfo{..} + | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize + = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler" + (ppr nativeCallStackSpillSize <+> text "stack words." <+> text "Use -fobject-code to get around this limit" ) | otherwise - = assert (length regs <= 24) {- 24 bits for bitmap -} - assert (tupleNativeStackSize < 255) {- 8 bits for stack size -} - assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -} - foldl' reg_bit 0 (zip regs [0..]) .|. - (fromIntegral tupleNativeStackSize `shiftL` 24) + = assertPpr (length regs <= 24) (text "too many registers for bitmap:" <+> ppr (length regs)) {- 24 bits for register bitmap -} + assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) {- 8 bits for continuation offset (only for NativeTupleReturn) -} + assertPpr (all (`elem` regs) (regSetToList nativeCallRegs)) (text "not all registers accounted for") {- all regs accounted for -} + foldl' reg_bit 0 (zip regs [0..]) .|. (cont_offset `shiftL` 24) where + cont_offset :: Word32 + cont_offset + | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize + | otherwise = 0 -- there is no continuation for primcalls + reg_bit :: Word32 -> (GlobalReg, Int) -> Word32 reg_bit x (r, n) - | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n - | otherwise = x - regs = tupleRegsCover platform + | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n + | otherwise = x + regs = allArgRegsCover platform -mkTupleInfoLit :: Platform -> TupleInfo -> Literal -mkTupleInfoLit platform tuple_info = - mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info +mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal +mkNativeCallInfoLit platform call_info = + mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the @@ -589,6 +641,7 @@ mkLitF :: Platform -> Float -> [Word] mkLitD :: Platform -> Double -> [Word] mkLitI64 :: Platform -> Int64 -> [Word] +mkLitW64 :: Platform -> Word64 -> [Word] mkLitF platform f = case platformWordSize platform of PW4 -> runST $ do @@ -635,13 +688,18 @@ w1 <- readArray d_arr 1 return [w0 :: Word,w1] ) - PW8 -> runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 ii + PW8 -> [fromIntegral ii :: Word] + +mkLitW64 platform ww = case platformWordSize platform of + PW4 -> runST (do + arr <- newArray_ ((0::Word),1) + writeArray arr 0 ww d_arr <- castSTUArray arr w0 <- readArray d_arr 0 - return [w0 :: Word] + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] ) + PW8 -> [fromIntegral ww :: Word] mkLitI i = [fromIntegral i :: Word] diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006 @@ -24,7 +25,9 @@ import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout +import Data.Int import Data.Word + import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax @@ -85,10 +88,9 @@ | PUSH_BCO (ProtoBCO Name) -- Push an alt continuation - | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep + | PUSH_ALTS (ProtoBCO Name) ArgRep | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation - !TupleInfo + !NativeCallInfo (ProtoBCO Name) -- tuple return BCO -- Pushing 8, 16 and 32 bits of padding (for constructors). @@ -110,6 +112,10 @@ -- type, and it appears impossible to get hold of the bits of -- an addr, even though we need to assemble BCOs. + -- Push a top-level Addr#. This is a pseudo-instruction assembled to PUSH_UBX, + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. + | PUSH_ADDR Name + -- various kinds of application | PUSH_APPLY_N | PUSH_APPLY_V @@ -141,6 +147,22 @@ | TESTEQ_I Int LocalLabel | TESTLT_W Word LocalLabel | TESTEQ_W Word LocalLabel + | TESTLT_I64 Int64 LocalLabel + | TESTEQ_I64 Int64 LocalLabel + | TESTLT_I32 Int32 LocalLabel + | TESTEQ_I32 Int32 LocalLabel + | TESTLT_I16 Int16 LocalLabel + | TESTEQ_I16 Int16 LocalLabel + | TESTLT_I8 Int8 LocalLabel + | TESTEQ_I8 Int16 LocalLabel + | TESTLT_W64 Word64 LocalLabel + | TESTEQ_W64 Word64 LocalLabel + | TESTLT_W32 Word32 LocalLabel + | TESTEQ_W32 Word32 LocalLabel + | TESTLT_W16 Word16 LocalLabel + | TESTEQ_W16 Word16 LocalLabel + | TESTLT_W8 Word8 LocalLabel + | TESTEQ_W8 Word8 LocalLabel | TESTLT_F Float LocalLabel | TESTEQ_F Float LocalLabel | TESTLT_D Double LocalLabel @@ -166,15 +188,18 @@ -- (XXX: inefficient, but I don't know -- what the alignment constraints are.) + | PRIMCALL + -- For doing magic ByteArray passing to foreign calls | SWIZZLE Word16 -- to the ptr N words down the stack, Word16 -- add M (interpreted as a signed 16-bit entity) -- To Infinity And Beyond | ENTER - | RETURN -- return a lifted value - | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep - | RETURN_TUPLE -- return an unboxed tuple (info already on stack) + | RETURN ArgRep -- return a non-tuple value, here's its rep; see + -- Note [Return convention for non-tuple values] in GHC.StgToByteCode + | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see + -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre) @@ -249,10 +274,9 @@ <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) - ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) - ppr (PUSH_ALTS_TUPLE bco tuple_info tuple_bco) = - hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info) + ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco) + ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) = + hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info) 2 (ppr tuple_bco $+$ ppr bco) @@ -264,6 +288,7 @@ ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit + ppr (PUSH_ADDR nm) = text "PUSH_ADDR" <+> ppr nm ppr PUSH_APPLY_N = text "PUSH_APPLY_N" ppr PUSH_APPLY_V = text "PUSH_APPLY_V" ppr PUSH_APPLY_F = text "PUSH_APPLY_F" @@ -291,6 +316,22 @@ ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTLT_I64 i lab) = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I64 i lab) = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I32 i lab) = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I32 i lab) = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I16 i lab) = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I16 i lab) = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I8 i lab) = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I8 i lab) = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W64 i lab) = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W64 i lab) = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W32 i lab) = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W32 i lab) = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W16 i lab) = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W16 i lab) = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W8 i lab) = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W8 i lab) = text "TESTEQ_W8" <+> ppr i <+> text "__" <> ppr lab ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab @@ -306,13 +347,16 @@ 0x1 -> text "(interruptible)" 0x2 -> text "(unsafe)" _ -> empty) + ppr PRIMCALL = text "PRIMCALL" ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" - ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk + ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "" + where mb_uniq = sdocOption sdocSuppressUniques $ \case + True -> text "" + False -> ppr uniq @@ -343,16 +387,14 @@ bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 bciStackUse PUSH_BCO{} = 1 -bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} + +bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + 3 + protoBCOStackUse bco -bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} + - 4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) = - -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t) + -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) -- tuple - -- (tuple_info, tuple_bco, stg_ret_t) + -- (call_info, tuple_bco, stg_ret_t) 1 {- profiling only -} + - 7 + fromIntegral (tupleSize info) + protoBCOStackUse bco + 7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco bciStackUse (PUSH_PAD8) = 1 -- overapproximation bciStackUse (PUSH_PAD16) = 1 -- overapproximation bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch @@ -360,6 +402,7 @@ bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch bciStackUse (PUSH_UBX _ nw) = fromIntegral nw +bciStackUse PUSH_ADDR{} = 1 bciStackUse PUSH_APPLY_N{} = 1 bciStackUse PUSH_APPLY_V{} = 1 bciStackUse PUSH_APPLY_F{} = 1 @@ -380,6 +423,22 @@ bciStackUse TESTEQ_I{} = 0 bciStackUse TESTLT_W{} = 0 bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_I64{} = 0 +bciStackUse TESTEQ_I64{} = 0 +bciStackUse TESTLT_I32{} = 0 +bciStackUse TESTEQ_I32{} = 0 +bciStackUse TESTLT_I16{} = 0 +bciStackUse TESTEQ_I16{} = 0 +bciStackUse TESTLT_I8{} = 0 +bciStackUse TESTEQ_I8{} = 0 +bciStackUse TESTLT_W64{} = 0 +bciStackUse TESTEQ_W64{} = 0 +bciStackUse TESTLT_W32{} = 0 +bciStackUse TESTEQ_W32{} = 0 +bciStackUse TESTLT_W16{} = 0 +bciStackUse TESTEQ_W16{} = 0 +bciStackUse TESTLT_W8{} = 0 +bciStackUse TESTEQ_W8{} = 0 bciStackUse TESTLT_F{} = 0 bciStackUse TESTEQ_F{} = 0 bciStackUse TESTLT_D{} = 0 @@ -389,10 +448,10 @@ bciStackUse CASEFAIL{} = 0 bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 0 -bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X +bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 +bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -8,10 +8,7 @@ -- | Bytecode assembler and linker module GHC.ByteCode.Linker - ( ClosureEnv - , emptyClosureEnv - , extendClosureEnv - , linkBCO + ( linkBCO , lookupStaticPtr , lookupIE , nameToCLabel @@ -36,6 +33,8 @@ import GHC.Data.FastString import GHC.Data.SizedSeq +import GHC.Linker.Types + import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable @@ -52,46 +51,35 @@ Linking interpretables into something we can run -} -type ClosureEnv = NameEnv (Name, ForeignHValue) - -emptyClosureEnv :: ClosureEnv -emptyClosureEnv = emptyNameEnv - -extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv -extendClosureEnv cl_env pairs - = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] - -{- - Linking interpretables into something we can run --} - linkBCO :: Interp - -> ItblEnv - -> ClosureEnv + -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp ie ce bco_ix breakarray +linkBCO interp le bco_ix breakarray (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. - lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0) - ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0) + lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0) + ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0) return (ResolvedBCO isLittleEndian arity insns bitmap (listArray (0, fromIntegral (sizeSS lits0)-1) lits) (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word -lookupLiteral interp ie ptr = case ptr of +lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word +lookupLiteral interp le ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp ie nm + Ptr a# <- lookupIE interp (itbl_env le) nm return (W# (int2Word# (addr2Int# a#))) + BCONPtrAddr nm -> do + Ptr a# <- lookupAddr interp (addr_env le) nm + return (W# (int2Word# (addr2Int# a#))) BCONPtrStr _ -> -- should be eliminated during assembleBCOs panic "lookupLiteral: BCONPtrStr" @@ -123,6 +111,20 @@ (unpackFS sym_to_find1 ++ " or " ++ unpackFS sym_to_find2) +-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode +lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ()) +lookupAddr interp ae addr_nm = do + case lookupNameEnv ae addr_nm of + Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) + Nothing -> do -- try looking up in the object files. + let sym_to_find = nameToCLabel addr_nm "bytes" + -- see Note [Bytes label] in GHC.Cmm.CLabel + m <- lookupSymbol interp sym_to_find + case m of + Just ptr -> return ptr + Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" + (unpackFS sym_to_find) + lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ()) lookupPrimOp interp primop = do let sym_to_find = primopToCLabel primop "closure" @@ -133,18 +135,17 @@ resolvePtr :: Interp - -> ItblEnv - -> ClosureEnv + -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of +resolvePtr interp le bco_ix breakarray ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group - | Just (_, rhv) <- lookupNameEnv ce nm + | Just (_, rhv) <- lookupNameEnv (closure_env le) nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) | otherwise @@ -160,7 +161,7 @@ -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco + -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco BCOPtrBreakArray -> return (ResolvedBCOPtrBreakArray breakarray) diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -3,7 +3,7 @@ assignArgumentsPos, assignStack, realArgRegsCover, - tupleRegsCover + allArgRegsCover ) where import GHC.Prelude @@ -221,12 +221,109 @@ realLongRegs platform -- we don't save XMM registers if they are not used for parameter passing --- Like realArgRegsCover but always includes the node. This covers the real --- and virtual registers used for unboxed tuples. --- --- Note: if anything changes in how registers for unboxed tuples overlap, --- make sure to also update GHC.StgToByteCode.layoutTuple. -tupleRegsCover :: Platform -> [GlobalReg] -tupleRegsCover platform = +{- + + Note [GHCi and native call registers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The GHCi bytecode interpreter does not have access to the STG registers + that the native calling convention uses for passing arguments. It uses + helper stack frames to move values between the stack and registers. + + If only a single register needs to be moved, GHCi uses a specific stack + frame. For example stg_ctoi_R1p saves a heap pointer value from STG register + R1 and stg_ctoi_D1 saves a double precision floating point value from D1. + In the other direction, helpers stg_ret_p and stg_ret_d move a value from + the stack to the R1 and D1 registers, respectively. + + When GHCi needs to move more than one register it cannot use a specific + helper frame. It would simply be impossible to create a helper for all + possible combinations of register values. Instead, there are generic helper + stack frames that use a call_info word that describes the active registers + and the number of stack words used by the arguments of a call. + + These helper stack frames are currently: + + - stg_ret_t: return a tuple to the continuation at the top of + the stack + - stg_ctoi_t: convert a tuple return value to be used in + bytecode + - stg_primcall: call a function + + + The call_info word contains a bitmap of the active registers + for the call and and a stack offset. The layout is as follows: + + - bit 0-23: Bitmap of active registers for the call, the + order corresponds to the list returned by + allArgRegsCover. For example if bit 0 (the least + significant bit) is set, the first register in the + allArgRegsCover list is active. Bit 1 for the + second register in the list and so on. + + - bit 24-31: Unsigned byte indicating the stack offset + of the continuation in words. For tuple returns + this is the number of words returned on the + stack. For primcalls this field is unused, since + we don't jump to a continuation. + + The upper 32 bits on 64 bit platforms are currently unused. + + If a register is smaller than a word on the stack (for example a + single precision float on a 64 bit system), then the stack slot + is padded to a whole word. + + Example: + + If a tuple is returned in three registers and an additional two + words on the stack, then three bits in the register bitmap + (bits 0-23) would be set. And bit 24-31 would be + 00000010 (two in binary). + + The values on the stack before a call to POP_ARG_REGS would + be as follows: + + ... + continuation + stack_arg_1 + stack_arg_2 + register_arg_3 + register_arg_2 + register_arg_1 <- Sp + + A call to POP_ARG_REGS(call_info) would move register_arg_1 + to the register corresponding to the lowest set bit in the + call_info word. register_arg_2 would be moved to the register + corresponding to the second lowest set bit, and so on. + + After POP_ARG_REGS(call_info), the stack pointer Sp points + to the topmost stack argument, so the stack looks as follows: + + ... + continuation + stack_arg_1 + stack_arg_2 <- Sp + + At this point all the arguments are in place and we are ready + to jump to the continuation, the location (offset from Sp) of + which is found by inspecting the value of bits 24-31. In this + case the offset is two words. + + On x86_64, the double precision (Dn) and single precision + floating (Fn) point registers overlap, e.g. D1 uses the same + physical register as F1. On this platform, the list returned + by allArgRegsCover contains only entries for the double + precision registers. If an argument is passed in register + Fn, the bit corresponding to Dn should be set. + + Note: if anything changes in how registers for native calls overlap, + make sure to also update GHC.StgToByteCode.layoutNativeCall + -} + +-- Like realArgRegsCover but always includes the node. This covers all real +-- and virtual registers actually used for passing arguments. + +allArgRegsCover :: Platform -> [GlobalReg] +allArgRegsCover platform = nub (VanillaReg 1 VGcPtr : realArgRegsCover platform) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -1238,8 +1238,8 @@ ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ), ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ), - ( fsLit "PUSH_TUPLE_REGS", \[live_regs] -> emitPushTupleRegs live_regs ), - ( fsLit "POP_TUPLE_REGS", \[live_regs] -> emitPopTupleRegs live_regs ), + ( fsLit "PUSH_ARG_REGS", \[live_regs] -> emitPushArgRegs live_regs ), + ( fsLit "POP_ARG_REGS", \[live_regs] -> emitPopArgRegs live_regs ), ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -693,12 +693,16 @@ -- 1. Compute Reg +/- n directly. -- For Add/Sub we can directly encode 12bits, or 12bits lsl #12. CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)] - | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + | n > 0 && n < 4096 + , w == W32 || w == W64 -- Work around #23749 + -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) r' = getRegisterReg plat reg CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)] - | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + | n > 0 && n < 4096 + , w == W32 || w == W64 -- Work around #23749 + -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) r' = getRegisterReg plat reg diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ /dev/null @@ -1,164 +0,0 @@ - --- | Utils for calculating general worst, bound, squeese and free, functions. --- --- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" --- Michael Smith, Normal Ramsey, Glenn Holloway. --- PLDI 2004 --- --- These general versions are not used in GHC proper because they are too slow. --- Instead, hand written optimised versions are provided for each architecture --- in MachRegs*.hs --- --- This code is here because we can test the architecture specific code against --- it. --- -module GHC.CmmToAsm.Reg.Graph.Base ( - RegClass(..), - Reg(..), - RegSub(..), - - worst, - bound, - squeese -) where - -import GHC.Prelude - -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM -import GHC.Types.Unique -import GHC.Builtin.Uniques -import GHC.Utils.Monad (concatMapM) - - --- Some basic register classes. --- These aren't necessarily in 1-to-1 correspondence with the allocatable --- RegClasses in MachRegs.hs -data RegClass - -- general purpose regs - = ClassG32 -- 32 bit GPRs - | ClassG16 -- 16 bit GPRs - | ClassG8 -- 8 bit GPRs - - -- floating point regs - | ClassF64 -- 64 bit FPRs - deriving (Show, Eq, Enum) - - --- | A register of some class -data Reg - -- a register of some class - = Reg RegClass Int - - -- a sub-component of one of the other regs - | RegSub RegSub Reg - deriving (Show, Eq) - - --- | so we can put regs in UniqSets -instance Uniquable Reg where - getUnique (Reg c i) - = mkRegSingleUnique - $ fromEnum c * 1000 + i - - getUnique (RegSub s (Reg c i)) - = mkRegSubUnique - $ fromEnum s * 10000 + fromEnum c * 1000 + i - - getUnique (RegSub _ (RegSub _ _)) - = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." - - --- | A subcomponent of another register -data RegSub - = SubL16 -- lowest 16 bits - | SubL8 -- lowest 8 bits - | SubL8H -- second lowest 8 bits - deriving (Show, Enum, Ord, Eq) - - --- | Worst case displacement --- --- a node N of classN has some number of neighbors, --- all of which are from classC. --- --- (worst neighbors classN classC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. --- --- This should be hand coded/cached for each particular architecture, --- because the compute time is very long.. -worst :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> Int -> RegClass -> RegClass -> Int - -worst regsOfClass regAlias neighbors classN classC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUniqSet regs - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- all the regs in classes N, C - regsN = regsOfClass classN - regsC = regsOfClass classC - - -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 - && sizeUniqSet s <= neighbors) - $ powersetLS regsC - - -- for each of the subsets of C, the regs which conflict - -- with posiblities for N - regsS_conflict - = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS - - in maximum $ map sizeUniqSet $ regsS_conflict - - --- | For a node N of classN and neighbors of classesC --- (bound classN classesC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. -bound :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [RegClass] -> Int - -bound regsOfClass regAlias classN classesC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUFM regs - -- See Note [Unique Determinism and code generation] - - regsC_aliases - = unionManyUniqSets - $ map (regAliasS . getUniqSet . regsOfClass) classesC - - overlap = intersectUniqSets (regsOfClass classN) regsC_aliases - - in sizeUniqSet overlap - - --- | The total squeese on a particular node with a list of neighbors. --- --- A version of this should be constructed for each particular architecture, --- possibly including uses of bound, so that aliased registers don't get --- counted twice, as per the paper. -squeese :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [(Int, RegClass)] -> Int - -squeese regsOfClass regAlias classN countCs - = sum - $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) - $ countCs - - --- | powerset (for lists) -powersetL :: [a] -> [[a]] -powersetL = concatMapM (\x -> [[],[x]]) - - --- | powersetLS (list of sets) -powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] -powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s - -- See Note [Unique Determinism and code generation] diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Register coalescing. -module GHC.CmmToAsm.Reg.Graph.Coalesce ( - regCoalesce, - slurpJoinMovs -) where -import GHC.Prelude - -import GHC.CmmToAsm.Reg.Liveness -import GHC.CmmToAsm.Instr -import GHC.Platform.Reg - -import GHC.Cmm -import GHC.Data.Bag -import GHC.Data.Graph.Directed -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Types.Unique.Supply - - --- | Do register coalescing on this top level thing --- --- For Reg -> Reg moves, if the first reg dies at the same time the --- second reg is born then the mov only serves to join live ranges. --- The two regs can be renamed to be the same and the move instruction --- safely erased. -regCoalesce - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM [LiveCmmDecl statics instr] - -regCoalesce code - = do - let joins = foldl' unionBags emptyBag - $ map slurpJoinMovs code - - let alloc = foldl' buildAlloc emptyUFM - $ bagToList joins - - let patched = map (patchEraseLive (sinkReg alloc)) code - - return patched - - --- | Add a v1 = v2 register renaming to the map. --- The register with the lowest lexical name is set as the --- canonical version. -buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg -buildAlloc fm (r1, r2) - = let rmin = min r1 r2 - rmax = max r1 r2 - in addToUFM fm rmax rmin - - --- | Determine the canonical name for a register by following --- v1 = v2 renamings in this map. -sinkReg :: UniqFM Reg Reg -> Reg -> Reg -sinkReg fm r - = case lookupUFM fm r of - Nothing -> r - Just r' -> sinkReg fm r' - - --- | Slurp out mov instructions that only serve to join live ranges. --- --- During a mov, if the source reg dies and the destination reg is --- born then we can rename the two regs to the same thing and --- eliminate the move. -slurpJoinMovs - :: Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpJoinMovs live - = slurpCmm emptyBag live - where - slurpCmm rs CmmData{} - = rs - - slurpCmm rs (CmmProc _ _ _ sccs) - = foldl' slurpBlock rs (flattenSCCs sccs) - - slurpBlock rs (BasicBlock _ instrs) - = foldl' slurpLI rs instrs - - slurpLI rs (LiveInstr _ Nothing) = rs - slurpLI rs (LiveInstr instr (Just live)) - | Just (r1, r2) <- takeRegRegMoveInstr instr - , elementOfUniqSet r1 $ liveDieRead live - , elementOfUniqSet r2 $ liveBorn live - - -- only coalesce movs between two virtuals for now, - -- else we end up with allocatable regs in the live - -- regs list.. - , isVirtualReg r1 && isVirtualReg r2 - = consBag (r1, r2) rs - - | otherwise - = rs - diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +++ /dev/null @@ -1,161 +0,0 @@ - --- | A description of the register set of the X86. --- --- This isn't used directly in GHC proper. --- --- See RegArchBase.hs for the reference. --- See MachRegs.hs for the actual trivColorable function used in GHC. --- -module GHC.CmmToAsm.Reg.Graph.X86 ( - classOfReg, - regsOfClass, - regName, - regAlias, - worst, - squeese, -) where - -import GHC.Prelude - -import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) -import GHC.Types.Unique.Set - -import qualified Data.Array as A - - --- | Determine the class of a register -classOfReg :: Reg -> RegClass -classOfReg reg - = case reg of - Reg c _ -> c - - RegSub SubL16 _ -> ClassG16 - RegSub SubL8 _ -> ClassG8 - RegSub SubL8H _ -> ClassG8 - - --- | Determine all the regs that make up a certain class. -regsOfClass :: RegClass -> UniqSet Reg -regsOfClass c - = case c of - ClassG32 - -> mkUniqSet [ Reg ClassG32 i - | i <- [0..7] ] - - ClassG16 - -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) - | i <- [0..7] ] - - ClassG8 - -> unionUniqSets - (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) - (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) - - ClassF64 - -> mkUniqSet [ Reg ClassF64 i - | i <- [0..5] ] - - --- | Determine the common name of a reg --- returns Nothing if this reg is not part of the machine. -regName :: Reg -> Maybe String -regName reg - = case reg of - Reg ClassG32 i - | i <= 7 -> - let names = A.listArray (0,8) - [ "eax", "ebx", "ecx", "edx" - , "ebp", "esi", "edi", "esp" ] - in Just $ names A.! i - - RegSub SubL16 (Reg ClassG32 i) - | i <= 7 -> - let names = A.listArray (0,8) - [ "ax", "bx", "cx", "dx" - , "bp", "si", "di", "sp"] - in Just $ names A.! i - - RegSub SubL8 (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"] - in Just $ names A.! i - - RegSub SubL8H (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"] - in Just $ names A.! i - - _ -> Nothing - - --- | Which regs alias what other regs. -regAlias :: Reg -> UniqSet Reg -regAlias reg - = case reg of - - -- 32 bit regs alias all of the subregs - Reg ClassG32 i - - -- for eax, ebx, ecx, eds - | i <= 3 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg - , RegSub SubL8 reg, RegSub SubL8H reg ] - - -- for esi, edi, esp, ebp - | 4 <= i && i <= 7 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg ] - - -- 16 bit subregs alias the whole reg - RegSub SubL16 r@(Reg ClassG32 _) - -> regAlias r - - -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg - RegSub SubL8 r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] - - RegSub SubL8H r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] - - -- fp - Reg ClassF64 _ - -> unitUniqSet reg - - _ -> error "regAlias: invalid register" - - --- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - ClassG32 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG16 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG8 - -> case classC of - ClassG32 -> min (n*2) 8 - ClassG16 -> min (n*2) 8 - ClassG8 -> min n 8 - ClassF64 -> 0 - - ClassF64 - -> case classC of - ClassF64 -> min n 6 - _ -> 0 - -squeese :: RegClass -> [(Int, RegClass)] -> Int -squeese classN countCs - = sum (map (\(i, classC) -> worst i classN classC) countCs) - diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -89,28 +89,35 @@ where anal_body env' | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs' + = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') - add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType - add_exported_uses env = foldl' (add_exported_use env) + keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv + -- See Note [Absence analysis for stable unfoldings and RULES] + -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in + -- orphan RULES + keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids)) - -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@ - -- corresponds to the demand type of @(id, e)@, but is a lot more direct. - -- See Note [Analysing top-level bindings]. - add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType - add_exported_use env dmd_ty id - | isExportedId id || elemVarSet id rule_fvs - -- See Note [Absence analysis for stable unfoldings and RULES] - = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id)) - | otherwise - = dmd_ty + is_root :: Id -> Bool + is_root id = isExportedId id || elemVarSet id rule_fvs rule_fvs :: IdSet rule_fvs = rulesRhsFreeIds rules +demandRoot :: AnalEnv -> Id -> DmdEnv +-- See Note [Absence analysis for stable unfoldings and RULES] +demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) + +demandRoots :: AnalEnv -> [Id] -> DmdEnv +-- See Note [Absence analysis for stable unfoldings and RULES] +demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots) + +demandRootSet :: AnalEnv -> IdSet -> DmdEnv +demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids) + -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative + -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings -- that satisfy this function. -- @@ -292,7 +299,7 @@ -- See Note [Absence analysis for stable unfoldings and RULES] rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs + final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -309,18 +316,18 @@ dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of NonRec id rhs - | (env', lazy_fv, id1, rhs1) <- + | (env', weak_fv, id1, rhs1) <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only) + -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) Rec pairs - | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' lazy_fv pairs' Rec + | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs + -> do_rest env' weak_fv pairs' Rec where - do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') + do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') where WithDmdType body_ty body' = anal_body env' -- see Note [Lazy and unleashable free variables] - dmd_ty = addLazyFVs body_ty lazy_fv + dmd_ty = addWeakFVs body_ty weak_fv WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) -- Important to force this as build_bind might not force it. !pairs2 = strictZipWith do_one pairs1 id_dmds @@ -350,15 +357,15 @@ -- See ↦* relation in the Cardinality Analysis paper dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* - -> CoreExpr -- Should obey the let/app invariant - -> (PlusDmdArg, CoreExpr) + -> CoreExpr + -> (DmdEnv, CoreExpr) dmdAnalStar env (n :* sd) e -- NB: (:*) expands AbsDmd and BotDmd as needed -- See Note [Analysing with absent demand] | WithDmdType dmd_ty e' <- dmdAnal env sd e = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e) -- The argument 'e' should satisfy the let/app invariant - (toPlusDmdArg $ multDmdType n dmd_ty, e') + (discardArgDmds $ multDmdType n dmd_ty, e') -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv @@ -371,13 +378,13 @@ dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co) - = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co) + = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) dmdAnal' env dmd (Var var) = WithDmdType (dmdTransform env var dmd) (Var var) dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co) + = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) where WithDmdType dmd_ty e' = dmdAnal env dmd e @@ -472,7 +479,7 @@ = alt_ty2 WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty + res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd @@ -517,7 +524,7 @@ = deferAfterPreciseException alt_ty1 | otherwise = alt_ty1 - res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut @@ -915,7 +922,7 @@ -- * Case and constructor field binders | otherwise = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ - unitDmdType (unitVarEnv var (C_11 :* sd)) + noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd)) {- ********************************************************************* * * @@ -923,6 +930,10 @@ * * ********************************************************************* -} +-- | An environment in which all demands are weak according to 'isWeakDmd'. +-- See Note [Lazy and unleashable free variables]. +type WeakDmds = VarEnv Demand + -- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature -- for the LetDown rule. It works as follows: -- @@ -937,13 +948,13 @@ -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, DmdEnv, Id, CoreExpr) + -> (AnalEnv, WeakDmds, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $ - (final_env, lazy_fv, final_id, final_rhs) + = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ + (final_env, weak_fvs, final_id, final_rhs) where rhs_arity = idArity id -- See Note [Demand signatures are computed for a threshold demand based on idArity] @@ -962,13 +973,11 @@ = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty - -- See Note [Do not unbox class dictionaries] - -- See Note [Boxity for bottoming functions] - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div - `orElse` (rhs_dmds, rhs') + DmdType rhs_env rhs_dmds = rhs_dmd_ty + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' (de_div rhs_env) + `orElse` (rhs_dmds, rhs') - sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div) + sig = mkDmdSigForArity rhs_arity (DmdType sig_env final_rhs_dmds) final_id = id `setIdDmdSig` sig !final_env = extendAnalEnv top_lvl env final_id sig @@ -985,16 +994,20 @@ -- we'd have to do an additional iteration. reuseEnv makes sure that -- we never get used-once info for FVs of recursive functions. -- See #14816 where we try to get rid of reuseEnv. - rhs_fv1 = case rec_flag of - Recursive -> reuseEnv rhs_fv - NonRecursive -> rhs_fv + rhs_env1 = case rec_flag of + Recursive -> reuseEnv rhs_env + NonRecursive -> rhs_env -- See Note [Absence analysis for stable unfoldings and RULES] - rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id + rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id) -- See Note [Lazy and unleashable free variables] - !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 + !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 +splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) +splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) + where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs + -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type @@ -1216,8 +1229,8 @@ Note [Absence analysis for stable unfoldings and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticket #18638 shows that it's really important to do absence analysis -for stable unfoldings. Consider +Among others, tickets #18638 and #23208 show that it's really important to treat +stable unfoldings as demanded. Consider g = blah @@ -1234,24 +1247,48 @@ Now if f is subsequently inlined, we'll use 'g' and ... disaster. -SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands -on its free variables) so that no variable mentioned in its unfolding -is Absent. This is done by the function Demand.keepAliveDmdEnv. +SOLUTION: if f has a stable unfolding, treat every free variable as a +/demand root/, that is: Analyse it as if it was a variable occuring in a +'topDmd' context. This is done in `demandRoot` (which we also use for exported +top-level ids). Do the same for Ids free in the RHS of any RULES for f. -ALSO: do the same for Ids free in the RHS of any RULES for f. +Wrinkles: -PS: You may wonder how it can be that f's optimised RHS has somehow -discarded 'g', but when f is inlined we /don't/ discard g in the same -way. I think a simple example is - g = (a,b) - f = \x. fst g - {-# INLINE f #-} + (W1) You may wonder how it can be that f's optimised RHS has somehow + discarded 'g', but when f is inlined we /don't/ discard g in the same + way. I think a simple example is + g = (a,b) + f = \x. fst g + {-# INLINE f #-} -Now f's optimised RHS will be \x.a, but if we change g to (error "..") -(since it is apparently Absent) and then inline (\x. fst g) we get -disaster. But regardless, #18638 was a more complicated version of -this, that actually happened in practice. + Now f's optimised RHS will be \x.a, but if we change g to (error "..") + (since it is apparently Absent) and then inline (\x. fst g) we get + disaster. But regardless, #18638 was a more complicated version of + this, that actually happened in practice. + (W2) You might wonder why we don't simply take the free vars of the + unfolding/RULE and map them to topDmd. The reason is that any of the free vars + might have demand signatures themselves that in turn demand transitive free + variables and that we hence need to unleash! This came up in #23208. + Consider + + err :: Int -> b + err = error "really important message" + + sg :: Int -> Int + sg _ = case err of {} -- Str=<1B>b {err:->S} + + g :: a -> a -- g is exported + g x = x + {-# RULES "g" g @Int = sg #-} + + Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur + in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg` + because it occurs in the RULEs of `g` (which is exported), we better unleash + the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd' + for `sg`, failing to unleash the signature and hence observed an absent + error instead of the `really important message`. + Note [Boxity for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1728,8 +1765,7 @@ -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info - + -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info dmdFix top_lvl env let_dmd orig_pairs = loop 1 initial_pairs where @@ -1739,33 +1775,33 @@ -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs) + abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) + abort = (env, weak_fv', zapped_pairs) + where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) -- Note [Lazy and unleashable free variables] - non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs' - lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs zapped_pairs = zapIdDmdSig pairs' -- The fixed-point varies the idDmdSig field of the binders, and terminates if that -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) -- | (id,_)<- pairs]) $ loop' n pairs loop' n pairs - | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | found_fixpoint = (final_anal_env, weak_fv, pairs') | n == 10 = abort | otherwise = loop (n+1) pairs' where found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs first_round = n == 1 - (lazy_fv, pairs') = step first_round pairs + (weak_fv, pairs') = step first_round pairs final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) - step first_round pairs = (lazy_fv, pairs') + step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) + step first_round pairs = (weak_fv, pairs') where -- In all but the first iteration, delete the virgin flag start_env | first_round = env @@ -1773,17 +1809,17 @@ start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs + !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed - my_downRhs (env, lazy_fv) (id,rhs) + my_downRhs (env, weak_fv) (id,rhs) = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', lazy_fv'), (id', rhs')) + ((env', weak_fv'), (id', rhs')) where - !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 + !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs + !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] @@ -1857,23 +1893,24 @@ * * ********************************************************************* -} -unitDmdType :: DmdEnv -> DmdType -unitDmdType dmd_env = DmdType dmd_env [] topDiv +noArgsDmdType :: DmdEnv -> DmdType +noArgsDmdType dmd_env = DmdType dmd_env [] coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv co = coercionsDmdEnv [co] coercionsDmdEnv :: [Coercion] -> DmdEnv -coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos) - -- The VarSet from coVarsOfCos is really a VarEnv Var +coercionsDmdEnv cos + = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos + -- The VarSet from coVarsOfCos is really a VarEnv Var addVarDmd :: DmdType -> Var -> Demand -> DmdType -addVarDmd (DmdType fv ds res) var dmd - = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res +addVarDmd (DmdType fv ds) var dmd + = DmdType (addVarDmdEnv fv var dmd) ds -addLazyFVs :: DmdType -> DmdEnv -> DmdType -addLazyFVs dmd_ty lazy_fvs - = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs +addWeakFVs :: DmdType -> WeakDmds -> DmdType +addWeakFVs dmd_ty weak_fvs + = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs -- Using plusDmdType (rather than just plus'ing the envs) -- is vital. Consider -- let f = \x -> (x,y) @@ -1882,7 +1919,7 @@ -- demand with the bottom coming up from 'error' -- -- I got a loop in the fixpointer without this, due to an interaction - -- with the lazy_fv filtering in dmdAnalRhsSig. Roughly, it was + -- with the weak_fv filtering in dmdAnalRhsSig. Roughly, it was -- letrec f n x -- = letrec g y = x `fatbar` -- letrec h z = z + ...g... @@ -1983,14 +2020,14 @@ But now the signature lies! (Missing variables are assumed to be absent.) To make up for this, the code that analyses the binding keeps the demand on those -variable separate (usually called "lazy_fv") and adds it to the demand of the +variable separate (usually called "weak_fv") and adds it to the demand of the whole binding later. What if we decide _not_ to store a strictness signature for a binding at all, as we do when aborting a fixed-point iteration? The we risk losing the information that the strict variables are being used. In that case, we take all free variables mentioned in the (unsound) strictness signature, conservatively approximate the -demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". +demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix". ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -3065,9 +3065,11 @@ ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut case_bndr case_bndr2 alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts -- NB: it's possible that the returned in_alts is empty: this is handled -- by the caller (rebuildCase) in the missingAlt function + -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts + -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts -- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () @@ -4077,7 +4079,7 @@ mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding mkLetUnfolding !uf_opts top_lvl src id new_rhs - = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In GHC.Iface.Tidy we currently assume that, if we want to @@ -4144,7 +4146,7 @@ -- A test case is #4138 -- But retain a previous boring_ok of True; e.g. see -- the way it is set in calcUnfoldingGuidanceWithArity - in return (mkCoreUnfolding src is_top_lvl expr' guide') + in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide') -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold _other -- Happens for INLINABLE things @@ -4299,7 +4301,9 @@ ; return (rule { ru_bndrs = bndrs' , ru_fn = fn_name' , ru_args = args' - , ru_rhs = rhs' }) } + , ru_rhs = occurAnalyseExpr rhs' }) } + -- Remember to occ-analyse, to drop dead code. + -- See Note [OccInfo in unfoldings and rules] in GHC.Core {- Note [Simplifying the RHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -2077,7 +2077,7 @@ = (poly_id `setIdUnfolding` unf, poly_rhs) where poly_rhs = mkLams tvs_here rhs - unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs + unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs Nothing -- We want the unfolding. Consider -- let @@ -2168,26 +2168,37 @@ If we inline h into f, the default case of the inlined h can't happen. If we don't notice this, we may end up filtering out *all* the cases of the inner case y, which give us nowhere to go! + +Note [Shadowing in prepareAlts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an +/OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build +a new /InAlt/. If you pass an OutId, we'll end up appling the +substitution twice: disaster (#23012). + +However this does mean that filling in the default alt might be +delayed by a simplifier cycle, because an InId has less info than an +OutId. Test simplCore/should_compile/simpl013 apparently shows this +up, although I'm not sure exactly how.. -} -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -- The returned alternatives can be empty, none are possible -prepareAlts scrut case_bndr' alts - | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') - -- Case binder is needed just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example +-- +-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts] +prepareAlts scrut case_bndr alts + | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr) = do { us <- getUniquesM - ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1 - -- the multiplicity on case_bndr's is the multiplicity of the + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1 + -- The multiplicity on case_bndr's is the multiplicity of the -- case expression The newly introduced patterns in -- refineDefaultAlt must be scaled by this multiplicity (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 -- "idcs" stands for "impossible default data constructors" -- i.e. the constructors that can't match the default case - ; when yes2 $ tick (FillInCaseDefault case_bndr') - ; when yes3 $ tick (AltMerge case_bndr') + ; when yes2 $ tick (FillInCaseDefault case_bndr) + ; when yes3 $ tick (AltMerge case_bndr) ; return (idcs3, alts3) } | otherwise -- Not a data type, so nothing interesting happens diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1891,15 +1891,16 @@ calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs = ( spec_lam_bndrs_w_dmds , spec_call_args - , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div ) + , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) ) where - DmdSig (DmdType _ fn_dmds div) = idDmdSig fn + DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn + spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] val_pats = filterOut isTypeArg pats -- Value args at call sites, used to determine how many demands to drop - -- from the original functions demand and for setting up dmd_env. - dmd_env = go emptyVarEnv fn_dmds val_pats - qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + -- from the original functions demand and for setting up arg_dmd_env. + arg_dmd_env = go emptyVarEnv fn_dmds val_pats + qvar_dmds = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] extra_dmds = dropList val_pats fn_dmds -- Annotate the variables with the strictness information from @@ -1923,12 +1924,12 @@ set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds | otherwise = setIdDemandInfo v d : set_dmds vs ds' - go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv + go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand -- We've filtered out all the type patterns already go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats go env _ _ = env - go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv + go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand go_one env d (Var v) = extendVarEnv_C plusDmd env v d go_one env (_n :* cd) e -- NB: _n does not have to be strict | (Var _, args) <- collectArgs e diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -50,10 +50,11 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var ( isLocalVar, mkLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Error import GHC.Utils.Error ( mkMCDiagnostic ) @@ -62,6 +63,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Trace +import GHC.Utils.Panic.Plain( assert ) import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts @@ -1523,12 +1525,49 @@ | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs - spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn - = Just (orig_join_arity - join_arity_decr) - | otherwise - = Nothing - ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity + simpl_opts = initSimpleOpts dflags + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + (spec_inl_prag, spec_unf) + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = (neverInlinePragma, noUnfolding) + -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" + + | isInlinablePragma inl_prag + = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) + + | otherwise + = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args) + rule_lhs_args fn_unf) + + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in GHC.Core.Opt.Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs + + -------------------------------------- + -- Add a suitable unfolding; see Note [Inline specialisations] + -- The wrap_unf_body applies the original unfolding to the specialised + -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) + spec_fn_info + = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) + `setInlinePragInfo` spec_inl_prag + `setUnfoldingInfo` spec_unf + + -- Compute the IdDetails of the specialise Id + -- See Note [Transfer IdDetails during specialisation] + spec_fn_details + = case idDetails fn of + JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing + DFunId is_nt -> DFunId is_nt + _ -> VanillaId + + ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'. @@ -1566,33 +1605,7 @@ -- See Note [Specialising Calls] spec_uds = foldr consDictBind rhs_uds dx_binds - simpl_opts = initSimpleOpts dflags - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - (spec_inl_prag, spec_unf) - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = (neverInlinePragma, noUnfolding) - -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" - - | isInlinablePragma inl_prag - = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) - - | otherwise - = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args) - rule_lhs_args fn_unf) - - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in GHC.Core.Opt.Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs - spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) - `setInlinePragma` spec_inl_prag - `setIdUnfolding` spec_unf - `asJoinId_maybe` spec_join_arity + spec_f_w_arity = spec_fn _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty @@ -1608,7 +1621,7 @@ {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DFuns have a special sort of unfolding (DFunUnfolding), and these are +DFuns have a special sort of unfolding (DFunUnfolding), and it is hard to specialise a DFunUnfolding to give another DFunUnfolding unless the DFun is fully applied (#18120). So, in the case of DFunIds we simply extend the CallKey with trailing UnspecArgs, so we'll @@ -1617,6 +1630,36 @@ There is an ASSERT that checks this, in the DFunUnfolding case of GHC.Core.Unfold.specUnfolding. +Note [Transfer IdDetails during specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, `newSpecIdSM` comes up with a fresh Id the +specialised RHS will be bound to. It is critical that we get the `IdDetails` of +the specialised Id correct: + +* JoinId: We want the specialised Id to be a join point, too. But + we have to carefully adjust the arity + +* DFunId: It is crucial that we also make the new Id a DFunId. + - First, because it obviously /is/ a DFun, having a DFunUnfolding and + all that; see Note [Specialising DFuns] + + - Second, DFuns get very delicate special treatment in the demand analyser; + see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't + also a DFunId, this special treatment doesn't happen, so the demand + analyser makes a too-strict DFun, and we get an infinite loop. See Note + [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal. + #22549 describes the loop, and (lower down) a case where a /specialised/ + DFun caused a loop. + +* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come + up when specialising imports. We must keep them as VanillaIds because WW + will detect them as WorkerLikeIds again. That is, unless specialisation + allows unboxing of all previous CBV args, in which case sticking to + VanillaIds was the only correct choice to begin with. + +* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId: + Never specialised. + Note [Specialisation Must Preserve Sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function: @@ -2980,15 +3023,14 @@ ty' = substTy env (idType b) ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) } -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id +newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id -- Give the new Id a similar occurrence name to the old one -newSpecIdSM old_id new_ty join_arity_maybe +newSpecIdSM old_name new_ty details info = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name) - `asJoinId_maybe` join_arity_maybe - ; return new_id } + ; let new_occ = mkSpecOcc (nameOccName old_name) + new_name = mkInternalName uniq new_occ (getSrcSpan old_name) + ; return (assert (not (isCoVarType new_ty)) $ + mkLocalVar details new_name Many new_ty info) } {- Old (but interesting) stuff about unboxed bindings diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1084,7 +1084,7 @@ where depth = val_args args stricts = case idDmdSig v of - DmdSig (DmdType _ demands _) + DmdSig (DmdType _ demands) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth | otherwise -> [] diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs deleted file mode 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ /dev/null @@ -1,938 +0,0 @@ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - - --- | This is the driver for the 'ghc --backpack' mode, which --- is a reimplementation of the "package manager" bits of --- Backpack directly in GHC. The basic method of operation --- is to compile packages and then directly insert them into --- GHC's in memory database. --- --- The compilation products of this mode aren't really suitable --- for Cabal, because GHC makes up component IDs for the things --- it builds and doesn't serialize out the database contents. --- But it's still handy for constructing tests. - -module GHC.Driver.Backpack (doBackpack) where - -import GHC.Prelude - --- In a separate module because it hooks into the parser. -import GHC.Driver.Backpack.Syntax -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Monad -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Main -import GHC.Driver.Make -import GHC.Driver.Env -import GHC.Driver.Errors -import GHC.Driver.Errors.Types - -import GHC.Parser -import GHC.Parser.Header -import GHC.Parser.Lexer -import GHC.Parser.Annotation - -import GHC.Rename.Names - -import GHC hiding (Failed, Succeeded) -import GHC.Tc.Utils.Monad -import GHC.Iface.Recomp -import GHC.Builtin.Names - -import GHC.Types.SrcLoc -import GHC.Types.SourceError -import GHC.Types.SourceFile -import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM -import GHC.Types.Unique.DSet - -import GHC.Utils.Outputable -import GHC.Utils.Fingerprint -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Error -import GHC.Utils.Logger - -import GHC.Unit -import GHC.Unit.Env -import GHC.Unit.External -import GHC.Unit.Finder -import GHC.Unit.Module.Graph -import GHC.Unit.Module.ModSummary -import GHC.Unit.Home.ModInfo - -import GHC.Linker.Types - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.Maybe -import GHC.Data.StringBuffer -import GHC.Data.FastString -import qualified GHC.Data.EnumSet as EnumSet -import qualified GHC.Data.ShortText as ST - -import Data.List ( partition ) -import System.Exit -import Control.Monad -import System.FilePath -import Data.Version - --- for the unification -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set - --- | Entry point to compile a Backpack file. -doBackpack :: [FilePath] -> Ghc () -doBackpack [src_filename] = do - -- Apply options from file to dflags - dflags0 <- getDynFlags - let dflags1 = dflags0 - let parser_opts1 = initParserOpts dflags1 - (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename - (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts - modifySession (hscSetFlags dflags) - logger <- getLogger -- Get the logger after having set the session flags, - -- so that logger options are correctly set. - -- Not doing so caused #20396. - -- Cribbed from: preprocessFile / GHC.Driver.Pipeline - liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns) - liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns - -- TODO: Preprocessing not implemented - - buf <- liftIO $ hGetStringBuffer src_filename - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great - case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) - POk _ pkgname_bkp -> do - -- OK, so we have an LHsUnit PackageName, but we want an - -- LHsUnit HsComponentId. So let's rename it. - hsc_env <- getSession - let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp - initBkpM src_filename bkp $ - forM_ (zip [1..] bkp) $ \(i, lunit) -> do - let comp_name = unLoc (hsunitName (unLoc lunit)) - msgTopPackage (i,length bkp) comp_name - innerBkpM $ do - let (cid, insts) = computeUnitId lunit - if null insts - then if cid == UnitId (fsLit "main") - then compileExe lunit - else compileUnit cid [] - else typecheckUnit cid insts -doBackpack _ = - throwGhcException (CmdLineError "--backpack can only process a single file") - -computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)]) -computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) - where - cid = hsComponentId (unLoc (hsunitName unit)) - reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) - get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname - get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet - get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet - get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = - unitFreeModuleHoles (convertHsComponentId hsuid) - --- | Tiny enum for all types of Backpack operations we may do. -data SessionType - -- | A compilation operation which will result in a - -- runnable executable being produced. - = ExeSession - -- | A type-checking operation which produces only - -- interface files, no object files. - | TcSession - -- | A compilation operation which produces both - -- interface files and object files. - | CompSession - deriving (Eq) - --- | Create a temporary Session to do some sort of type checking or --- compilation. -withBkpSession :: UnitId - -> [(ModuleName, Module)] - -> [(Unit, ModRenaming)] - -> SessionType -- what kind of session are we doing - -> BkpM a -- actual action to run - -> BkpM a -withBkpSession cid insts deps session_type do_this = do - dflags <- getDynFlags - let cid_fs = unitFS cid - is_primary = False - uid_str = unpackFS (mkInstantiatedUnitHash cid insts) - cid_str = unpackFS cid_fs - -- There are multiple units in a single Backpack file, so we - -- need to separate out the results in those cases. Right now, - -- we follow this hierarchy: - -- $outputdir/$compid --> typecheck results - -- $outputdir/$compid/$unitid --> compile results - key_base p | Just f <- p dflags = f - | otherwise = "." - sub_comp p | is_primary = p - | otherwise = p cid_str - outdir p | CompSession <- session_type - -- Special case when package is definite - , not (null insts) = sub_comp (key_base p) uid_str - | otherwise = sub_comp (key_base p) - - mk_temp_env hsc_env = - hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env - mk_temp_dflags unit_state dflags = dflags - { backend = case session_type of - TcSession -> NoBackend - _ -> backend dflags - , ghcLink = case session_type of - TcSession -> NoLink - _ -> ghcLink dflags - , homeUnitInstantiations_ = insts - -- if we don't have any instantiation, don't - -- fill `homeUnitInstanceOfId` as it makes no - -- sense (we're not instantiating anything) - , homeUnitInstanceOf_ = if null insts then Nothing else Just cid - , homeUnitId_ = case session_type of - TcSession -> newUnitId cid Nothing - -- No hash passed if no instances - _ | null insts -> newUnitId cid Nothing - | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)) - - - -- If we're type-checking an indefinite package, we want to - -- turn on interface writing. However, if the user also - -- explicitly passed in `-fno-code`, we DON'T want to write - -- interfaces unless the user also asked for `-fwrite-interface`. - -- See Note [-fno-code mode] - , generalFlags = case session_type of - -- Make sure to write interfaces when we are type-checking - -- indefinite packages. - TcSession - | backend dflags /= NoBackend - -> EnumSet.insert Opt_WriteInterface (generalFlags dflags) - _ -> generalFlags dflags - - -- Setup all of the output directories according to our hierarchy - , objectDir = Just (outdir objectDir) - , hiDir = Just (outdir hiDir) - , stubDir = Just (outdir stubDir) - -- Unset output-file for non exe builds - , outputFile_ = case session_type of - ExeSession -> outputFile_ dflags - _ -> Nothing - , dynOutputFile_ = case session_type of - ExeSession -> dynOutputFile_ dflags - _ -> Nothing - -- Clear the import path so we don't accidentally grab anything - , importPaths = [] - -- Synthesize the flags - , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnit unit_state - $ improveUnit unit_state - $ renameHoleUnit unit_state (listToUFM insts) uid0 - in ExposePackage - (showSDoc dflags - (text "-unit-id" <+> ppr uid <+> ppr rn)) - (UnitIdArg uid) rn) deps - } - withTempSession mk_temp_env $ do - dflags <- getSessionDynFlags - -- pprTrace "flags" (ppr insts <> ppr deps) $ return () - setSessionDynFlags dflags -- calls initUnits - do_this - -withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a -withBkpExeSession deps do_this = - withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this - -getSource :: UnitId -> BkpM (LHsUnit HsComponentId) -getSource cid = do - bkp_env <- getBkpEnv - case Map.lookup cid (bkp_table bkp_env) of - Nothing -> pprPanic "missing needed dependency" (ppr cid) - Just lunit -> return lunit - -typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () -typecheckUnit cid insts = do - lunit <- getSource cid - buildUnit TcSession cid insts lunit - -compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () -compileUnit cid insts = do - -- Let everyone know we're building this unit - msgUnitId (mkVirtUnit cid insts) - lunit <- getSource cid - buildUnit CompSession cid insts lunit - --- | Compute the dependencies with instantiations of a syntactic --- HsUnit; e.g., wherever you see @dependency p[A=]@ in a --- unit file, return the 'Unit' corresponding to @p[A=]@. --- The @include_sigs@ parameter controls whether or not we also --- include @dependency signature@ declarations in this calculation. --- --- Invariant: this NEVER returns UnitId. -hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)] -hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) - where - get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) - | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)] - | otherwise = [] - where - go Nothing = ModRenaming True [] - go (Just lrns) = ModRenaming False (map convRn lrns) - where - convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) - convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) - get_dep _ = [] - -buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () -buildUnit session cid insts lunit = do - -- NB: include signature dependencies ONLY when typechecking. - -- If we're compiling, it's not necessary to recursively - -- compile a signature since it isn't going to produce - -- any object files. - let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) - raw_deps = map fst deps_w_rns - hsc_env <- getSession - -- The compilation dependencies are just the appropriately filled - -- in unit IDs which must be compiled before we can compile. - let hsubst = listToUFM insts - deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps - - -- Build dependencies OR make sure they make sense. BUT NOTE, - -- we can only check the ones that are fully filled; the rest - -- we have to defer until we've typechecked our local signature. - -- TODO: work this into GHC.Driver.Make!! - forM_ (zip [1..] deps0) $ \(i, dep) -> - case session of - TcSession -> return () - _ -> compileInclude (length deps0) (i, dep) - - -- IMPROVE IT - let deps = map (improveUnit (hsc_units hsc_env)) deps0 - - mb_old_eps <- case session of - TcSession -> fmap Just getEpsGhc - _ -> return Nothing - - conf <- withBkpSession cid insts deps_w_rns session $ do - - dflags <- getDynFlags - mod_graph <- hsunitModuleGraph False (unLoc lunit) - - msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - - let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags - export_mod ms = (ms_mod_name ms, ms_mod ms) - -- Export everything! - mods = [ export_mod ms | ms <- mgModSummaries mod_graph - , ms_hsc_src ms == HsSrcFile ] - - -- Compile relevant only - hsc_env <- getSession - let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . hm_linkable) - . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) - $ home_mod_infos - getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - state = hsc_units hsc_env - - let compat_fs = unitIdFS cid - compat_pn = PackageName compat_fs - unit_id = homeUnitId (hsc_home_unit hsc_env) - - return GenericUnitInfo { - -- Stub data - unitAbiHash = "", - unitPackageId = PackageId compat_fs, - unitPackageName = compat_pn, - unitPackageVersion = makeVersion [], - unitId = unit_id, - unitComponentName = Nothing, - unitInstanceOf = cid, - unitInstantiations = insts, - -- Slight inefficiency here haha - unitExposedModules = map (\(m,n) -> (m,Just n)) mods, - unitHiddenModules = [], -- TODO: doc only - unitDepends = case session of - -- Technically, we should state that we depend - -- on all the indefinite libraries we used to - -- typecheck this. However, this field isn't - -- really used for anything, so we leave it - -- blank for now. - TcSession -> [] - _ -> map (toUnitId . unwireUnit state) - $ deps ++ [ moduleUnit mod - | (_, mod) <- insts - , not (isHoleModule mod) ], - unitAbiDepends = [], - unitLinkerOptions = case session of - TcSession -> [] - _ -> map ST.pack $ obj_files, - unitImportDirs = [ ST.pack $ hi_dir ], - unitIsExposed = False, - unitIsIndefinite = case session of - TcSession -> True - _ -> False, - -- nope - unitLibraries = [], - unitExtDepLibsSys = [], - unitExtDepLibsGhc = [], - unitLibraryDynDirs = [], - unitLibraryDirs = [], - unitExtDepFrameworks = [], - unitExtDepFrameworkDirs = [], - unitCcOptions = [], - unitIncludes = [], - unitIncludeDirs = [], - unitHaddockInterfaces = [], - unitHaddockHTMLs = [], - unitIsTrusted = False - } - - - addUnit conf - case mb_old_eps of - Just old_eps -> updateEpsGhc_ (const old_eps) - _ -> return () - -compileExe :: LHsUnit HsComponentId -> BkpM () -compileExe lunit = do - msgUnitId mainUnit - let deps_w_rns = hsunitDeps False (unLoc lunit) - deps = map fst deps_w_rns - -- no renaming necessary - forM_ (zip [1..] deps) $ \(i, dep) -> - compileInclude (length deps) (i, dep) - withBkpExeSession deps_w_rns $ do - mod_graph <- hsunitModuleGraph True (unLoc lunit) - msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - --- | Register a new virtual unit database containing a single unit -addUnit :: GhcMonad m => UnitInfo -> m () -addUnit u = do - hsc_env <- getSession - logger <- getLogger - let dflags0 = hsc_dflags hsc_env - let old_unit_env = hsc_unit_env hsc_env - newdbs <- case ue_unit_dbs old_unit_env of - Nothing -> panic "addUnit: called too early" - Just dbs -> - let newdb = UnitDatabase - { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" - , unitDatabaseUnits = [u] - } - in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) - - -- update platform constants - dflags <- liftIO $ updatePlatformConstants dflags0 mconstants - - let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv - { ue_platform = targetPlatform dflags - , ue_namever = ghcNameVersion dflags - , ue_current_unit = homeUnitId home_unit - - , ue_home_unit_graph = - unitEnv_singleton - (homeUnitId home_unit) - (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) - , ue_eps = ue_eps old_unit_env - } - setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } - -compileInclude :: Int -> (Int, Unit) -> BkpM () -compileInclude n (i, uid) = do - hsc_env <- getSession - let pkgs = hsc_units hsc_env - msgInclude (i, n) uid - -- Check if we've compiled it already - case uid of - HoleUnit -> return () - RealUnit _ -> return () - VirtUnit i -> case lookupUnit pkgs uid of - Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) - Just _ -> return () - --- ---------------------------------------------------------------------------- --- Backpack monad - --- | Backpack monad is a 'GhcMonad' which also maintains a little extra state --- beyond the 'Session', c.f. 'BkpEnv'. -type BkpM = IOEnv BkpEnv - --- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', --- because we are going to update the 'HscEnv' as we go. -data BkpEnv - = BkpEnv { - -- | The session - bkp_session :: Session, - -- | The filename of the bkp file we're compiling - bkp_filename :: FilePath, - -- | Table of source units which we know how to compile - bkp_table :: Map UnitId (LHsUnit HsComponentId), - -- | When a package we are compiling includes another package - -- which has not been compiled, we bump the level and compile - -- that. - bkp_level :: Int - } - --- Blah, to get rid of the default instance for IOEnv --- TODO: just make a proper new monad for BkpM, rather than use IOEnv -instance {-# OVERLAPPING #-} HasDynFlags BkpM where - getDynFlags = fmap hsc_dflags getSession -instance {-# OVERLAPPING #-} HasLogger BkpM where - getLogger = fmap hsc_logger getSession - - -instance GhcMonad BkpM where - getSession = do - Session s <- fmap bkp_session getEnv - readMutVar s - setSession hsc_env = do - Session s <- fmap bkp_session getEnv - writeMutVar s hsc_env - --- | Get the current 'BkpEnv'. -getBkpEnv :: BkpM BkpEnv -getBkpEnv = getEnv - --- | Get the nesting level, when recursively compiling modules. -getBkpLevel :: BkpM Int -getBkpLevel = bkp_level `fmap` getBkpEnv - --- | Run a 'BkpM' computation, with the nesting level bumped one. -innerBkpM :: BkpM a -> BkpM a -innerBkpM do_this = - -- NB: withTempSession mutates, so we don't have to worry - -- about bkp_session being stale. - updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this - --- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. -updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () -updateEpsGhc_ f = do - hsc_env <- getSession - liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ())) - --- | Get the EPS from a 'GhcMonad'. -getEpsGhc :: GhcMonad m => m ExternalPackageState -getEpsGhc = do - hsc_env <- getSession - liftIO $ hscEPS hsc_env - --- | Run 'BkpM' in 'Ghc'. -initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a -initBkpM file bkp m = - reifyGhc $ \session -> do - let env = BkpEnv { - bkp_session = session, - bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], - bkp_filename = file, - bkp_level = 0 - } - runIOEnv env m - --- ---------------------------------------------------------------------------- --- Messaging - --- | Print a compilation progress message, but with indentation according --- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> Logger -> SDoc -> IO () -backpackProgressMsg level logger msg = - compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr - <> msg - --- | Creates a 'Messager' for Backpack compilation; this is basically --- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which --- handles indentation. -mkBackpackMsg :: BkpM Messager -mkBackpackMsg = do - level <- getBkpLevel - return $ \hsc_env mod_index recomp node -> - let dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - state = hsc_units hsc_env - showMsg msg reason = - backpackProgressMsg level logger $ pprWithUnitState state $ - showModuleIndex mod_index <> - msg <> showModMsg dflags (recompileRequired recomp) node - <> reason - in case node of - InstantiationNode _ _ -> - case recomp of - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty - | otherwise -> return () - NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of - MustCompile -> empty - RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - ModuleNode _ _ -> - case recomp of - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty - | otherwise -> return () - NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of - MustCompile -> empty - RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - LinkNode _ _ -> showMsg (text "Linking ") empty - --- | 'PprStyle' for Backpack messages; here we usually want the module to --- be qualified (so we can tell how it was instantiated.) But we try not --- to qualify packages so we can use simple names for them. -backpackStyle :: PprStyle -backpackStyle = - mkUserStyle - (QueryQualify neverQualifyNames - alwaysQualifyModules - neverQualifyPackages) AllTheWay - --- | Message when we initially process a Backpack unit. -msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () -msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do - logger <- getLogger - level <- getBkpLevel - liftIO . backpackProgressMsg level logger - $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn - --- | Message when we instantiate a Backpack unit. -msgUnitId :: Unit -> BkpM () -msgUnitId pk = do - logger <- getLogger - hsc_env <- getSession - level <- getBkpLevel - let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger - $ pprWithUnitState state - $ text "Instantiating " - <> withPprStyle backpackStyle (ppr pk) - --- | Message when we include a Backpack unit. -msgInclude :: (Int,Int) -> Unit -> BkpM () -msgInclude (i,n) uid = do - logger <- getLogger - hsc_env <- getSession - level <- getBkpLevel - let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger - $ pprWithUnitState state - $ showModuleIndex (i, n) <> text "Including " - <> withPprStyle backpackStyle (ppr uid) - --- ---------------------------------------------------------------------------- --- Conversion from PackageName to HsComponentId - -type PackageNameMap a = UniqFM PackageName a - --- For now, something really simple, since we're not actually going --- to use this for anything -unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) -unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (UnitId fs)) - -bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId -bkpPackageNameMap units = listToUFM (map unitDefines units) - -renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] -renameHsUnits pkgstate m units = map (fmap renameHsUnit) units - where - - renamePackageName :: PackageName -> HsComponentId - renamePackageName pn = - case lookupUFM m pn of - Nothing -> - case lookupPackageName pkgstate pn of - Nothing -> error "no package name" - Just cid -> HsComponentId pn cid - Just hscid -> hscid - - renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId - renameHsUnit u = - HsUnit { - hsunitName = fmap renamePackageName (hsunitName u), - hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) - } - - renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId - renameHsUnitDecl (DeclD a b c) = DeclD a b c - renameHsUnitDecl (IncludeD idecl) = - IncludeD IncludeDecl { - idUnitId = fmap renameHsUnitId (idUnitId idecl), - idModRenaming = idModRenaming idecl, - idSignatureInclude = idSignatureInclude idecl - } - - renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId - renameHsUnitId (HsUnitId ln subst) - = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) - - renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId - renameHsModuleSubst (lk, lm) - = (lk, fmap renameHsModuleId lm) - - renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId - renameHsModuleId (HsModuleVar lm) = HsModuleVar lm - renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm - -convertHsComponentId :: HsUnitId HsComponentId -> Unit -convertHsComponentId (HsUnitId (L _ hscid) subst) - = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) - -convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) -convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) - -convertHsModuleId :: HsModuleId HsComponentId -> Module -convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname -convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname - - - -{- -************************************************************************ -* * - Module graph construction -* * -************************************************************************ --} - --- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications: --- --- 1. Every module is required to be mentioned, so we don't do any funny --- business with targets or recursively grabbing dependencies. (We --- could support this in principle). --- 2. We support inline modules, whose summary we have to synthesize ourself. --- --- We don't bother trying to support GHC.Driver.Make for now, it's more trouble --- than it's worth for inline modules. -hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph -hsunitModuleGraph do_link unit = do - hsc_env <- getSession - - let decls = hsunitBody unit - pn = hsPackageName (unLoc (hsunitName unit)) - home_unit = hsc_home_unit hsc_env - - sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit)) - keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ] - - -- 1. Create a HsSrcFile/HsigFile summary for every - -- explicitly mentioned module/signature. - let get_decl (L _ (DeclD hsc_src lmodname hsmod)) = - Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys) - get_decl _ = return Nothing - nodes <- mapMaybeM get_decl decls - - -- 2. For each hole which does not already have an hsig file, - -- create an "empty" hsig file to induce compilation for the - -- requirement. - let hsig_set = Set.fromList - [ ms_mod_name ms - | ModuleNode _ ms <- nodes - , ms_hsc_src ms == HsigFile - ] - req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> - if Set.member mod_name hsig_set - then return Nothing - else fmap Just $ summariseRequirement pn mod_name - - let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env)) - key_nodes = map mkNodeKey graph_nodes - all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] - -- This error message is not very good but .bkp mode is just for testing so - -- better to be direct rather than pretty. - when - (length key_nodes /= length (ordNub key_nodes)) - (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes)) - - -- 3. Return the kaboodle - return $ mkModuleGraph $ all_nodes - - -summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode -summariseRequirement pn mod_name = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - let home_unit = hsc_home_unit hsc_env - let fopts = initFinderOpts dflags - - let PackageName pn_fs = pn - let location = mkHomeModLocation2 fopts mod_name - (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" - - env <- getBkpEnv - src_hash <- liftIO $ getFileHash (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) - let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) - - let fc = hsc_FC hsc_env - mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name - - let ms = ModSummary { - ms_mod = mod, - ms_hsc_src = HsigFile, - ms_location = location, - ms_hs_hash = src_hash, - ms_obj_date = Nothing, - ms_dyn_obj_date = Nothing, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_srcimps = [], - ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports, - ms_ghc_prim_import = False, - ms_parsed_mod = Just (HsParsedModule { - hpm_module = L loc (HsModule { - hsmodAnn = noAnn, - hsmodLayout = NoLayoutInfo, - hsmodName = Just (L (noAnnSrcSpan loc) mod_name), - hsmodExports = Nothing, - hsmodImports = [], - hsmodDecls = [], - hsmodDeprecMessage = Nothing, - hsmodHaddockModHeader = Nothing - }), - hpm_src_files = [] - }), - ms_hspp_file = "", -- none, it came inline - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing - } - let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ] - return (ModuleNode nodes ms) - -summariseDecl :: PackageName - -> HscSource - -> Located ModuleName - -> Located HsModule - -> [NodeKey] - -> BkpM ModuleGraphNode -summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod - --- | Up until now, GHC has assumed a single compilation target per source file. --- Backpack files with inline modules break this model, since a single file --- may generate multiple output files. How do we decide to name these files? --- Should there only be one output file? This function our current heuristic, --- which is we make a "fake" module and use that. -hsModuleToModSummary :: [NodeKey] - -> PackageName - -> HscSource - -> ModuleName - -> Located HsModule - -> BkpM ModuleGraphNode -hsModuleToModSummary home_keys pn hsc_src modname - hsmod = do - let imps = hsmodImports (unLoc hsmod) - loc = getLoc hsmod - hsc_env <- getSession - -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation - -- Use the PACKAGE NAME to find the location - let PackageName unit_fs = pn - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags - -- Unfortunately, we have to define a "fake" location in - -- order to appease the various code which uses the file - -- name to figure out where to put, e.g. object files. - -- To add insult to injury, we don't even actually use - -- these filenames to figure out where the hi files go. - -- A travesty! - let location0 = mkHomeModLocation2 fopts modname - (unpackFS unit_fs - moduleNameSlashes modname) - (case hsc_src of - HsigFile -> "hsig" - HsBootFile -> "hs-boot" - HsSrcFile -> "hs") - -- DANGEROUS: bootifying can POISON the module finder cache - let location = case hsc_src of - HsBootFile -> addBootSuffixLocnOut location0 - _ -> location0 - -- This duplicates a pile of logic in GHC.Driver.Make - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) - - -- Also copied from 'getImports' - let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - (ordinary_imps, ghc_prim_import) - = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports modname loc - implicit_prelude imps - - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname - convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname - - let normal_imports = map convImport (implicit_imports ++ ordinary_imps) - (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports - - -- So that Finder can find it, even though it doesn't exist... - this_mod <- liftIO $ do - let home_unit = hsc_home_unit hsc_env - let fc = hsc_FC hsc_env - addHomeModuleToFinder fc home_unit modname location - let ms = ModSummary { - ms_mod = this_mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = (case hiDir dflags of - Nothing -> "" - Just d -> d) ".." moduleNameSlashes modname <.> "hi", - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing, - ms_srcimps = map convImport src_idecls, - ms_ghc_prim_import = not (null ghc_prim_import), - ms_textual_imps = normal_imports - -- We have to do something special here: - -- due to merging, requirements may end up with - -- extra imports - ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports) - ++ ((,) NoPkgQual . noLoc <$> implicit_sigs), - -- This is our hack to get the parse tree to the right spot - ms_parsed_mod = Just (HsParsedModule { - hpm_module = hsmod, - hpm_src_files = [] -- TODO if we preprocessed it - }), - -- Source hash = fingerprint0, so the recompilation tests do not recompile - -- too much. In future, if necessary then could get the hash by just hashing the - -- relevant part of the .bkp file. - ms_hs_hash = fingerprint0, - ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS - ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp - } - - -- Now, what are the dependencies. - let inst_nodes = map NodeKey_Unit inst_deps - mod_nodes = - -- hs-boot edge - [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++ - -- Normal edges - [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] - - - return (ModuleNode (mod_nodes ++ inst_nodes) ms) - --- | Create a new, externally provided hashed unit id from --- a hash. -newUnitId :: UnitId -> Maybe FastString -> UnitId -newUnitId uid mhash = case mhash of - Nothing -> uid - Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -281,7 +281,7 @@ -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes - | platformMisc_libFFI $ platformMisc dflags = "#include \n" + | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n" | otherwise = "" stub_h_file_exists diff --git a/compiler/GHC/Driver/Config/Stg/Pipeline.hs b/compiler/GHC/Driver/Config/Stg/Pipeline.hs --- a/compiler/GHC/Driver/Config/Stg/Pipeline.hs +++ b/compiler/GHC/Driver/Config/Stg/Pipeline.hs @@ -22,6 +22,7 @@ , stgPipeline_pprOpts = initStgPprOpts dflags , stgPipeline_phases = getStgToDo for_bytecode dflags , stgPlatform = targetPlatform dflags + , stgPipeline_forBytecode = for_bytecode } -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc. diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs deleted file mode 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ /dev/null @@ -1,452 +0,0 @@ - - ------------------------------------------------------------------------------ --- --- Makefile Dependency Generation --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module GHC.Driver.MakeFile - ( doMkDependHS - ) -where - -import GHC.Prelude - -import qualified GHC -import GHC.Driver.Monad -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Misc -import GHC.Driver.Env -import GHC.Driver.Errors.Types -import qualified GHC.SysTools as SysTools -import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Types.SourceError -import GHC.Types.SrcLoc -import GHC.Types.PkgQual -import Data.List (partition) -import GHC.Utils.TmpFs - -import GHC.Iface.Load (cannotFindModule) - -import GHC.Unit.Module -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.Graph -import GHC.Unit.Finder - -import GHC.Utils.Exception -import GHC.Utils.Error -import GHC.Utils.Logger - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when, forM_ ) -import Data.Maybe ( isJust ) -import Data.IORef -import qualified Data.Set as Set - ------------------------------------------------------------------ --- --- The main function --- ------------------------------------------------------------------ - -doMkDependHS :: GhcMonad m => [FilePath] -> m () -doMkDependHS srcs = do - logger <- getLogger - - -- Initialisation - dflags0 <- GHC.getSessionDynFlags - - -- We kludge things a bit for dependency generation. Rather than - -- generating dependencies for each way separately, we generate - -- them once and then duplicate them for each way's osuf/hisuf. - -- We therefore do the initial dependency generation with an empty - -- way and .o/.hi extensions, regardless of any flags that might - -- be specified. - let dflags1 = dflags0 - { targetWays_ = Set.empty - , hiSuf_ = "hi" - , objectSuf_ = "o" - } - GHC.setSessionDynFlags dflags1 - - -- If no suffix is provided, use the default -- the empty one - let dflags = if null (depSuffixes dflags1) - then dflags1 { depSuffixes = [""] } - else dflags1 - - tmpfs <- hsc_tmpfs <$> getSession - files <- liftIO $ beginMkDependHS logger tmpfs dflags - - -- Do the downsweep to find all the modules - targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs - GHC.setTargets targets - let excl_mods = depExcludeMods dflags - module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} - - -- Sort into dependency order - -- There should be no cycles - let sorted = GHC.topSortModuleGraph False module_graph Nothing - - -- Print out the dependencies if wanted - liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) - - -- Process them one by one, dumping results into makefile - -- and complaining about cycles - hsc_env <- getSession - root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted - - -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles logger module_graph - - -- Tidy up - liftIO $ endMkDependHS logger files - - -- Unconditional exiting is a bad idea. If an error occurs we'll get an - --exception; if that is not caught it's fine, but at least we have a - --chance to find out exactly what went wrong. Uncomment the following - --line if you disagree. - - --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) - ------------------------------------------------------------------ --- --- beginMkDependHs --- Create a temporary file, --- find the Makefile, --- slurp through it, etc --- ------------------------------------------------------------------ - -data MkDepFiles - = MkDep { mkd_make_file :: FilePath, -- Name of the makefile - mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile - mkd_tmp_file :: FilePath, -- Name of the temporary file - mkd_tmp_hdl :: Handle } -- Handle of the open temporary file - -beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles -beginMkDependHS logger tmpfs dflags = do - -- open a new temp file in which to stuff the dependency info - -- as we go along. - tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" - tmp_hdl <- openFile tmp_file WriteMode - - -- open the makefile - let makefile = depMakefile dflags - exists <- doesFileExist makefile - mb_make_hdl <- - if not exists - then return Nothing - else do - makefile_hdl <- openFile makefile ReadMode - - -- slurp through until we get the magic start string, - -- copying the contents into dep_makefile - let slurp = do - l <- hGetLine makefile_hdl - if (l == depStartMarker) - then return () - else do hPutStrLn tmp_hdl l; slurp - - -- slurp through until we get the magic end marker, - -- throwing away the contents - let chuck = do - l <- hGetLine makefile_hdl - if (l == depEndMarker) - then return () - else chuck - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - catchIO chuck - (\e -> if isEOFError e then return () else ioError e) - - return (Just makefile_hdl) - - - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depStartMarker - - return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - - ------------------------------------------------------------------ --- --- processDeps --- ------------------------------------------------------------------ - -processDeps :: DynFlags - -> HscEnv - -> [ModuleName] - -> FilePath - -> Handle -- Write dependencies to here - -> SCC ModuleGraphNode - -> IO () --- Write suitable dependencies to handle --- Always: --- this.o : this.hs --- --- If the dependency is on something other than a .hi file: --- this.o this.p_o ... : dep --- otherwise --- this.o ... : dep.hi --- this.p_o ... : dep.p_hi --- ... --- (where .o is $osuf, and the other suffixes come from --- the cmdline -s options). --- --- For {-# SOURCE #-} imports the "hi" will be "hi-boot". - -processDeps dflags _ _ _ _ (CyclicSCC nodes) - = -- There shouldn't be any cycles; report them - throwGhcExceptionIO $ ProgramError $ - showSDoc dflags $ GHC.cyclicModuleErr nodes - -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) - = -- There shouldn't be any backpack instantiations; report them as well - throwGhcExceptionIO $ ProgramError $ - showSDoc dflags $ - vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" - , nest 2 $ ppr node ] -processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () - -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node)) - = do { let extra_suffixes = depSuffixes dflags - include_pkg_deps = depIncludePkgDeps dflags - src_file = msHsFilePath node - obj_file = msObjFilePath node - obj_files = insertSuffixes obj_file extra_suffixes - - do_imp loc is_boot pkg_qual imp_mod - = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod - is_boot include_pkg_deps - ; case mb_hi of { - Nothing -> return () ; - Just hi_file -> do - { let hi_files = insertSuffixes hi_file extra_suffixes - write_dep (obj,hi) = writeDependency root hdl [obj] hi - - -- Add one dependency for each suffix; - -- e.g. A.o : B.hi - -- A.x_o : B.x_hi - ; mapM_ write_dep (obj_files `zip` hi_files) }}} - - - -- Emit std dependency of the object(s) on the source file - -- Something like A.o : A.hs - ; writeDependency root hdl obj_files src_file - - -- add dependency between objects and their corresponding .hi-boot - -- files if the module has a corresponding .hs-boot file (#14482) - ; when (isBootSummary node == IsBoot) $ do - let hi_boot = msHiFilePath node - let obj = removeBootSuffix (msObjFilePath node) - forM_ extra_suffixes $ \suff -> do - let way_obj = insertSuffixes obj [suff] - let way_hi_boot = insertSuffixes hi_boot [suff] - mapM_ (writeDependency root hdl way_obj) way_hi_boot - - -- Emit a dependency for each CPP import - ; when (depIncludeCppDeps dflags) $ do - -- CPP deps are descovered in the module parsing phase by parsing - -- comment lines left by the preprocessor. - -- Note that GHC.parseModule may throw an exception if the module - -- fails to parse, which may not be desirable (see #16616). - { session <- Session <$> newIORef hsc_env - ; parsedMod <- reflectGhc (GHC.parseModule node) session - ; mapM_ (writeDependency root hdl obj_files) - (GHC.pm_extra_src_files parsedMod) - } - - -- Emit a dependency for each import - - ; let do_imps is_boot idecls = sequence_ - [ do_imp loc is_boot mb_pkg mod - | (mb_pkg, L loc mod) <- idecls, - mod `notElem` excl_mods ] - - ; do_imps IsBoot (ms_srcimps node) - ; do_imps NotBoot (ms_imps node) - } - - -findDependency :: HscEnv - -> SrcSpan - -> PkgQual -- package qualifier, if any - -> ModuleName -- Imported module - -> IsBootInterface -- Source import - -> Bool -- Record dependency on package modules - -> IO (Maybe FilePath) -- Interface file -findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do - -- Find the module; this will be fast because - -- we've done it once during downsweep - r <- findImportedModule hsc_env imp pkg - case r of - Found loc _ - -- Home package: just depend on the .hi or hi-boot file - | isJust (ml_hs_file loc) || include_pkg_deps - -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) - - -- Not in this package: we don't need a dependency - | otherwise - -> return Nothing - - fail -> - throwOneError $ - mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ - cannotFindModule hsc_env imp fail - ------------------------------ -writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () --- (writeDependency r h [t1,t2] dep) writes to handle h the dependency --- t1 t2 : dep -writeDependency root hdl targets dep - = do let -- We need to avoid making deps on - -- c:/foo/... - -- on cygwin as make gets confused by the : - -- Making relative deps avoids some instances of this. - dep' = makeRelative root dep - forOutput = escapeSpaces . reslash Forwards . normalise - output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' - hPutStrLn hdl output - ------------------------------ -insertSuffixes - :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Suffix prefixes e.g. ["x_", "y_"] - -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] - -- Note that the extra bit gets inserted *before* the old suffix - -- We assume the old suffix contains no dots, so we know where to - -- split it -insertSuffixes file_name extras - = [ basename <.> (extra ++ suffix) | extra <- extras ] - where - (basename, suffix) = case splitExtension file_name of - -- Drop the "." from the extension - (b, s) -> (b, drop 1 s) - - ------------------------------------------------------------------ --- --- endMkDependHs --- Complete the makefile, close the tmp file etc --- ------------------------------------------------------------------ - -endMkDependHS :: Logger -> MkDepFiles -> IO () - -endMkDependHS logger - (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) - = do - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depEndMarker - - case makefile_hdl of - Nothing -> return () - Just hdl -> do - -- slurp the rest of the original makefile and copy it into the output - SysTools.copyHandle hdl tmp_hdl - hClose hdl - - hClose tmp_hdl -- make sure it's flushed - - -- Create a backup of the original makefile - when (isJust makefile_hdl) $ do - showPass logger ("Backing up " ++ makefile) - SysTools.copyFile makefile (makefile++".bak") - - -- Copy the new makefile in place - showPass logger "Installing new makefile" - SysTools.copyFile tmp_file makefile - - ------------------------------------------------------------------ --- Module cycles ------------------------------------------------------------------ - -dumpModCycles :: Logger -> ModuleGraph -> IO () -dumpModCycles logger module_graph - | not (logHasDumpFlag logger Opt_D_dump_mod_cycles) - = return () - - | null cycles - = putMsg logger (text "No module cycles") - - | otherwise - = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) - where - topoSort = GHC.topSortModuleGraph True module_graph Nothing - - cycles :: [[ModuleGraphNode]] - cycles = - [ c | CyclicSCC c <- topoSort ] - - pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------") - $$ pprCycle c $$ blankLine - | (n,c) <- [1..] `zip` cycles ] - -pprCycle :: [ModuleGraphNode] -> SDoc --- Print a cycle, but show only the imports within the cycle -pprCycle summaries = pp_group (CyclicSCC summaries) - where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] - - pp_group :: SCC ModuleGraphNode -> SDoc - pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms - pp_group (AcyclicSCC _) = empty - pp_group (CyclicSCC mss) - = assert (not (null boot_only)) $ - -- The boot-only list must be non-empty, else there would - -- be an infinite chain of non-boot imports, and we've - -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) - where - (boot_only, others) = partition is_boot_only mss - is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms))) - is_boot_only _ = False - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] - - loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) - all_others = tail boot_only ++ others - groups = - GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing - - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) - - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms - ------------------------------------------------------------------ --- --- Flags --- ------------------------------------------------------------------ - -depStartMarker, depEndMarker :: String -depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" -depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -799,18 +799,18 @@ else use (T_LlvmMangle pipe_env hsc_env llc_fn) asPipeline False pipe_env hsc_env location mangled_fn -cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath +cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmCppPipeline pipe_env hsc_env input_fn = do output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn) cmmPipeline pipe_env hsc_env output_fn -cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath +cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmPipeline pipe_env hsc_env input_fn = do (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn) mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn case mo_fn of - Nothing -> panic "CMM pipeline - produced no .o file" - Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos) + Nothing -> return Nothing + Just mo_fn -> Just <$> use (T_MergeForeign pipe_env hsc_env mo_fn fos) hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing @@ -873,8 +873,8 @@ fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn fromPhase StopLn = return (Just input_fn) - fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn - fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn + fromPhase CmmCpp = cmmCppPipeline pipe_env hsc_env input_fn + fromPhase Cmm = cmmPipeline pipe_env hsc_env input_fn fromPhase MergeForeign = panic "fromPhase: MergeForeign" {- diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -600,8 +600,8 @@ = pure i rnIfaceUnfolding :: Rename IfaceUnfolding -rnIfaceUnfolding (IfCoreUnfold stable if_expr) - = IfCoreUnfold stable <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfCoreUnfold stable cache if_expr) + = IfCoreUnfold stable cache <$> rnIfaceExpr if_expr rnIfaceUnfolding (IfCompulsory if_expr) = IfCompulsory <$> rnIfaceExpr if_expr rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -51,7 +51,7 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info -import GHC.Types.Demand ( isDeadEndAppSig, isTopSig, isDeadEndSig ) +import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) @@ -1253,7 +1253,7 @@ mb_bot_str = exprBotStrictness_maybe orig_rhs sig = dmdSigInfo idinfo - final_sig | not $ isTopSig sig + final_sig | not $ isNopSig sig = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig -- try a cheap-and-cheerful bottom analyser | Just (_, nsig) <- mb_bot_str = nsig diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1722,12 +1722,12 @@ tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -- See Note [Lazily checking Unfoldings] -tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) +tcUnfolding toplvl name _ info (IfCoreUnfold stable cache if_expr) = do { uf_opts <- unfoldingOpts <$> getDynFlags ; expr <- tcUnfoldingRhs False toplvl name if_expr ; let unf_src | stable = InlineStable | otherwise = InlineRhs - ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr } + ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr (Just cache) } where -- Strictness should occur before unfolding! strict_sig = dmdSigInfo info @@ -1738,7 +1738,7 @@ tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) = do { expr <- tcUnfoldingRhs False toplvl name if_expr - ; return $ mkCoreUnfolding InlineStable True expr guidance } + ; return $ mkCoreUnfolding InlineStable True expr Nothing guidance } where guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } @@ -1749,6 +1749,49 @@ where doc = text "Class ops for dfun" <+> ppr name (_, _, cls, _) = tcSplitDFunTy dfun_ty + +{- Note [Tying the 'CoreUnfolding' knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding of recursive definitions can contain references to the +Id being defined. Consider the following example: + + foo :: () + foo = foo + +The unfolding template of 'foo' is, of course, 'foo'; so the interface +file for this module contains: + + foo :: (); Unfolding = foo + +When rehydrating the interface file we are going to make an Id for +'foo' (in GHC.IfaceToCore), with an 'Unfolding'. We used to make this +'Unfolding' by calling 'mkFinalUnfolding', but that needs to populate, +among other fields, the 'uf_is_value' field, by computing +'exprIsValue' of the template (in this case, 'foo'). + +'exprIsValue e' looks at the unfoldings of variables in 'e' to see if +they are evaluated; so it consults the `uf_is_value` field of +variables in `e`. Now we can see the problem: to set the `uf_is_value` +field of `foo`'s unfolding, we look at its unfolding (in this case +just `foo` itself!). Loop. This is the root cause of ticket #22272. + +The simple solution we chose is to serialise the various auxiliary +fields of `CoreUnfolding` so that we don't need to recreate them when +rehydrating. Specifically, the following fields are moved to the +'UnfoldingCache', which is persisted in the interface file: + +* 'uf_is_conlike' +* 'uf_is_value' +* 'uf_is_work_free' +* 'uf_expandable' + +These four bits make the interface files only one byte larger per +unfolding; on the other hand, this does save calls to 'exprIsValue', +'exprIsExpandable' etc for every imported Id. + +We could choose to do this only for loop breakers. But that's a bit +more complicated and it seems good all round. +-} {- Note [Lazily checking Unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Linker.hs b/compiler/GHC/Linker.hs deleted file mode 100644 --- a/compiler/GHC/Linker.hs +++ /dev/null @@ -1,36 +0,0 @@ -module GHC.Linker - ( - ) -where - -import GHC.Prelude () - -- We need this dummy dependency for the make build system. Otherwise it - -- tries to load GHC.Types which may not be built yet. - --- Note [Linkers and loaders] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Linkers are used to produce linked objects (.so, executables); loaders are --- used to link in memory (e.g., in GHCi) with the already loaded libraries --- (ghc-lib, rts, etc.). --- --- Linking can usually be done with an external linker program ("ld"), but --- loading is more tricky: --- --- * Fully dynamic: --- when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.) --- and the modules to load are also compiled for dynamic linking, a --- solution is to fully rely on external tools: --- --- 1) link a .so with the external linker --- 2) load the .so with POSIX's "dlopen" --- --- * When GHC is built as a static program or when libraries we want to load --- aren't compiled for dynamic linking, GHC uses its own loader ("runtime --- linker"). The runtime linker is part of the rts (rts/Linker.c). --- --- Note that within GHC's codebase we often use the word "linker" to refer to --- the static object loader in the runtime system. --- --- Loading can be delegated to an external interpreter ("iserv") when --- -fexternal-interpreter is used. diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -140,8 +140,11 @@ emptyLoaderState :: LoaderState emptyLoaderState = LoaderState - { closure_env = emptyNameEnv - , itbl_env = emptyNameEnv + { linker_env = LinkerEnv + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , addr_env = emptyNameEnv + } , pkgs_loaded = init_pkgs , bcos_loaded = emptyModuleEnv , objs_loaded = emptyModuleEnv @@ -156,17 +159,16 @@ extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = - modifyLoaderState_ interp $ \pls@LoaderState{..} -> do - let new_ce = extendClosureEnv closure_env new_bindings - return $! pls{ closure_env = new_ce } + modifyLoaderState_ interp $ \pls -> do + return $! modifyClosureEnv pls $ \ce -> + extendClosureEnv ce new_bindings -- strictness is important for not retaining old copies of the pls deleteFromLoadedEnv :: Interp -> [Name] -> IO () deleteFromLoadedEnv interp to_remove = modifyLoaderState_ interp $ \pls -> do - let ce = closure_env pls - let new_ce = delListFromNameEnv ce to_remove - return pls{ closure_env = new_ce } + return $ modifyClosureEnv pls $ \ce -> + delListFromNameEnv ce to_remove -- | Load the module containing the given Name and get its associated 'HValue'. -- @@ -184,7 +186,7 @@ then throwGhcExceptionIO (ProgramError "") else return (pls', links, pkgs) - case lookupNameEnv (closure_env pls) name of + case lookupNameEnv (closure_env (linker_env pls)) name of Just (_,aa) -> return (pls,(aa, links, pkgs)) Nothing -> assertPpr (isExternalName name) (ppr name) $ do let sym_to_find = nameToCLabel name "closure" @@ -246,10 +248,7 @@ -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ - modifyLoaderState_ interp $ \pls -> - let cur = closure_env pls - new = delListFromNameEnv cur (map fst new_env) - in return pls{ closure_env = new } + deleteFromLoadedEnv interp (map fst new_env) -- | Display the loader state. @@ -593,13 +592,11 @@ then throwGhcExceptionIO (ProgramError "") else do -- Load the expression itself - let ie = itbl_env pls - ce = closure_env pls - -- Load the necessary packages and linkables - let nobreakarray = error "no break array" + let le = linker_env pls + nobreakarray = error "no break array" bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco + resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco bco_opts <- initBCOOpts (hsc_dflags hsc_env) [root_hvref] <- createBCOs interp bco_opts [resolved] fhv <- mkFinalizedHValue interp root_hvref @@ -910,15 +907,16 @@ then throwGhcExceptionIO (ProgramError "") else do -- Link the expression itself - let ie = plusNameEnv (itbl_env pls) bc_itbls - ce = closure_env pls + let le = linker_env pls + le2 = le { itbl_env = plusNameEnv (itbl_env le) bc_itbls + , addr_env = plusNameEnv (addr_env le) bc_strs } -- Link the necessary packages and linkables bco_opts <- initBCOOpts (hsc_dflags hsc_env) - new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc] + new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings - let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs - , itbl_env = ie } + let ce2 = extendClosureEnv (closure_env le2) nms_fhvs + !pls2 = pls { linker_env = le2 { closure_env = ce2 } } return (pls2, (nms_fhvs, links_needed, units_needed)) where free_names = uniqDSetToList $ @@ -1136,11 +1134,12 @@ cbcs = map byteCodeOfObject unlinkeds - ies = map bc_itbls cbcs - gce = closure_env pls - final_ie = foldr plusNameEnv (itbl_env pls) ies + le1 = linker_env pls + ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs) + ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) + le2 = le1 { itbl_env = ie2, addr_env = ae2 } - names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs + names_and_refs <- linkSomeBCOs bco_opts interp le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -1150,21 +1149,20 @@ -- Wrap finalizers on the ones we want to keep new_binds <- makeForeignNamedHValueRefs interp to_add - return pls1 { closure_env = extendClosureEnv gce new_binds, - itbl_env = final_ie } + let ce2 = extendClosureEnv (closure_env le2) new_binds + return $! pls1 { linker_env = le2 { closure_env = ce2 } } -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: BCOOpts -> Interp - -> ItblEnv - -> ClosureEnv + -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)] -- The returned HValueRefs are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods [] +linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of @@ -1177,7 +1175,7 @@ let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] names = map (unlinkedBCOName . snd) flat bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco + resolved <- sequence [ linkBCO interp le bco_ix breakarray bco | (breakarray, bco) <- flat ] hvrefs <- createBCOs interp bco_opts resolved return (zip names hvrefs) @@ -1267,15 +1265,11 @@ let -- Note that we want to remove all *local* -- (i.e. non-isExternal) names too (these are the -- temporary bindings from the command line). - keep_name :: (Name, a) -> Bool - keep_name (n,_) = isExternalName n && - nameModule n `elemModuleEnv` remaining_bcos_loaded - - itbl_env' = filterNameEnv keep_name itbl_env - closure_env' = filterNameEnv keep_name closure_env + keep_name :: Name -> Bool + keep_name n = isExternalName n && + nameModule n `elemModuleEnv` remaining_bcos_loaded - !new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', + !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env, bcos_loaded = remaining_bcos_loaded, objs_loaded = remaining_objs_loaded } diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs deleted file mode 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ /dev/null @@ -1,270 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHCi Interactive debugging commands --- --- Pepe Iborra (supported by Google SoC) 2006 --- --- ToDo: lots of violation of layering here. This module should --- decide whether it is above the GHC API (import GHC and nothing --- else) or below it. --- ------------------------------------------------------------------------------ - -module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where - -import GHC.Prelude - -import GHC - -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Monad -import GHC.Driver.Env - -import GHC.Linker.Loader - -import GHC.Runtime.Heap.Inspect -import GHC.Runtime.Interpreter -import GHC.Runtime.Context - -import GHC.Iface.Syntax ( showToHeader ) -import GHC.Iface.Env ( newInteractiveBinder ) -import GHC.Core.Type - -import GHC.Utils.Outputable -import GHC.Utils.Error -import GHC.Utils.Monad -import GHC.Utils.Exception -import GHC.Utils.Logger - -import GHC.Types.Id -import GHC.Types.Id.Make (ghcPrimIds) -import GHC.Types.Name -import GHC.Types.Var hiding ( varName ) -import GHC.Types.Var.Set -import GHC.Types.Unique.Set -import GHC.Types.TyThing.Ppr -import GHC.Types.TyThing - -import Control.Monad -import Control.Monad.Catch as MC -import Data.List ( (\\), partition ) -import Data.Maybe -import Data.IORef - -------------------------------------- --- | The :print & friends commands -------------------------------------- -pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () -pprintClosureCommand bindThings force str = do - tythings <- (catMaybes . concat) `liftM` - mapM (\w -> GHC.parseName w >>= - mapM GHC.lookupName) - (words str) - - -- Sort out good and bad tythings for :print and friends - let (pprintables, unpprintables) = partition can_pprint tythings - - -- Obtain the terms and the recovered type information - let ids = [id | AnId id <- pprintables] - (subst, terms) <- mapAccumLM go emptyTCvSubst ids - - -- Apply the substitutions obtained after recovering the types - modifySession $ \hsc_env -> - hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} - - -- Finally, print the Results - docterms <- mapM showTerm terms - let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) - ids - docterms - printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms - where - -- Check whether a TyThing can be processed by :print and friends. - -- Take only Ids, exclude pseudoops, they don't have any HValues. - can_pprint :: TyThing -> Bool -- #19394 - can_pprint (AnId x) - | x `notElem` ghcPrimIds = True - | otherwise = False - can_pprint _ = False - - -- Create a short message for a TyThing, that cannot processed by :print - no_pprint :: TyThing -> SDoc - no_pprint tything = ppr tything <+> - text "is not eligible for the :print, :sprint or :force commands." - - -- Helper to print out the results of :print and friends - printSDocs :: GhcMonad m => [SDoc] -> m () - printSDocs sdocs = do - logger <- getLogger - unqual <- GHC.getPrintUnqual - liftIO $ printOutputForUser logger unqual $ vcat sdocs - - -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) - go subst id = do - let id' = updateIdTypeAndMult (substTy subst) id - id_ty' = idType id' - term_ <- GHC.obtainTermFromId maxBound force id' - term <- tidyTermTyVars term_ - term' <- if bindThings - then bindSuspensions term - else return term - -- Before leaving, we compare the type obtained to see if it's more specific - -- Then, we extract a substitution, - -- mapping the old tyvars to the reconstructed types. - let reconstructed_type = termType term - hsc_env <- getSession - case (improveRTTIType hsc_env id_ty' reconstructed_type) of - Nothing -> return (subst, term') - Just subst' -> do { logger <- getLogger - ; liftIO $ - putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" - FormatText - (fsep $ [text "RTTI Improvement for", ppr id, - text "old substitution:" , ppr subst, - text "new substitution:" , ppr subst']) - ; return (subst `unionTCvSubst` subst', term')} - - tidyTermTyVars :: GhcMonad m => Term -> m Term - tidyTermTyVars t = - withSession $ \hsc_env -> do - let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env - my_tvs = termTyCoVars t - tvs = env_tvs `minusVarSet` my_tvs - tyvarOccName = nameOccName . tyVarName - tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) - -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv - -- forgets the ordering immediately by creating an env - , getUniqSet $ env_tvs `intersectVarSet` my_tvs) - return $ mapTermType (snd . tidyOpenType tidyEnv) t - --- | Give names, and bind in the interactive environment, to all the suspensions --- included (inductively) in a term -bindSuspensions :: GhcMonad m => Term -> m Term -bindSuspensions t = do - hsc_env <- getSession - inScope <- GHC.getBindings - let ictxt = hsc_IC hsc_env - prefix = "_t" - alreadyUsedNames = map (occNameString . nameOccName . getName) inScope - availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames - availNames_var <- liftIO $ newIORef availNames - (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t - let (names, tys, fhvs) = unzip3 stuff - let ids = [ mkVanillaGlobal name ty - | (name,ty) <- zip names tys] - new_ic = extendInteractiveContextWithIds ictxt ids - interp = hscInterp hsc_env - liftIO $ extendLoadedEnv interp (zip names fhvs) - setSession hsc_env {hsc_IC = new_ic } - return t' - where - --- Processing suspensions. Give names and recopilate info - nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] - -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) - nameSuspensionsAndGetInfos hsc_env freeNames = TermFold - { - fSuspension = doSuspension hsc_env freeNames - , fTerm = \ty dc v tt -> do - tt' <- sequence tt - let (terms,names) = unzip tt' - return (Term ty dc v terms, concat names) - , fPrim = \ty n ->return (Prim ty n,[]) - , fNewtypeWrap = - \ty dc t -> do - (term, names) <- t - return (NewtypeWrap ty dc term, names) - , fRefWrap = \ty t -> do - (term, names) <- t - return (RefWrap ty term, names) - } - doSuspension hsc_env freeNames ct ty hval _name = do - name <- atomicModifyIORef' freeNames (\x->(tail x, head x)) - n <- newGrimName hsc_env name - return (Suspension ct ty hval (Just n), [(n,ty,hval)]) - - --- A custom Term printer to enable the use of Show instances -showTerm :: GhcMonad m => Term -> m SDoc -showTerm term = do - dflags <- GHC.getSessionDynFlags - if gopt Opt_PrintEvldWithShow dflags - then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term - else cPprTerm cPprTermBase term - where - cPprShowable prec t@Term{ty=ty, val=fhv} = - if not (isFullyEvaluatedTerm t) - then return Nothing - else do - let set_session = do - hsc_env <- getSession - (new_env, bname) <- bindToFreshName hsc_env ty "showme" - setSession new_env - - -- this disables logging of errors - let noop_log _ _ _ _ = return () - pushLogHookM (const noop_log) - - return (hsc_env, bname) - - reset_session (old_env,_) = setSession old_env - - MC.bracket set_session reset_session $ \(_,bname) -> do - hsc_env <- getSession - dflags <- GHC.getSessionDynFlags - let expr = "Prelude.return (Prelude.show " ++ - showPpr dflags bname ++ - ") :: Prelude.IO Prelude.String" - interp = hscInterp hsc_env - txt_ <- withExtendedLoadedEnv interp - [(bname, fhv)] - (GHC.compileExprRemote expr) - let myprec = 10 -- application precedence. TODO Infix constructors - txt <- liftIO $ evalString interp txt_ - if not (null txt) then - return $ Just $ cparen (prec >= myprec && needsParens txt) - (text txt) - else return Nothing - - cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = - cPprShowable prec t{ty=new_ty} - cPprShowable _ _ = return Nothing - - needsParens ('"':_) = False -- some simple heuristics to see whether parens - -- are redundant in an arbitrary Show output - needsParens ('(':_) = False - needsParens txt = ' ' `elem` txt - - - bindToFreshName hsc_env ty userName = do - name <- newGrimName hsc_env userName - let id = mkVanillaGlobal name ty - new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] - return (hsc_env {hsc_IC = new_ic }, name) - --- Create new uniques and give them sequentially numbered names -newGrimName :: MonadIO m => HscEnv -> String -> m Name -newGrimName hsc_env userName - = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) - where - occ = mkOccName varName userName - -pprTypeAndContents :: GhcMonad m => Id -> m SDoc -pprTypeAndContents id = do - dflags <- GHC.getSessionDynFlags - let pcontents = gopt Opt_PrintBindContents dflags - pprdId = (pprTyThing showToHeader . AnId) id - if pcontents - then do - let depthBound = 100 - -- If the value is an exception, make sure we catch it and - -- show the exception, rather than propagating the exception out. - e_term <- MC.try $ GHC.obtainTermFromId depthBound False id - docs_term <- case e_term of - Right term -> showTerm term - Left exn -> return (text "*** Exception:" <+> - text (show (exn :: SomeException))) - return $ pprdId <+> equals <+> docs_term - else return pprdId diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs --- a/compiler/GHC/Stg/InferTags.hs +++ b/compiler/GHC/Stg/InferTags.hs @@ -204,6 +204,33 @@ over the exact StgPass we are using. Which allows us to run the analysis on the output of itself. +Note [Tag inference for interpreted code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The bytecode interpreter has a different behaviour when it comes +to the tagging of binders in certain situations than the StgToCmm code generator. + +a) Tags for let-bindings: + + When compiling a binding for a constructor like `let x = Just True` + Whether `x` will be properly tagged depends on the backend. + For the interpreter x points to a BCO which once + evaluated returns a properly tagged pointer to the heap object. + In the Cmm backend for the same binding we would allocate the constructor right + away and x will immediately be represented by a tagged pointer. + This means for interpreted code we can not assume let bound constructors are + properly tagged. Hence we distinguish between targeting bytecode and native in + the analysis. + We make this differentiation in `mkLetSig` where we simply never assume + lets are tagged when targeting bytecode. + +b) When referencing ids from other modules the Cmm backend will try to put a + proper tag on these references through various means. When doing analysis we + usually predict these cases to improve precision of the analysis. + But to my knowledge the bytecode generator makes no such attempts so we must + not infer imported bindings as tagged. + This is handled in GHC.Stg.InferTags.Types.lookupInfo + + -} {- ********************************************************************* @@ -212,20 +239,12 @@ * * ********************************************************************* -} --- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] --- -> CollectedCCs --- -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs --- -> HpcInfo --- -> IO (Stream IO CmmGroupSRTs CmmCgInfos) --- -- Note we produce a 'Stream' of CmmGroups, so that the --- -- backend can be run incrementally. Otherwise it generates all --- -- the C-- up front, which has a significant space cost. -inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) -inferTags ppr_opts logger this_mod stg_binds = do - +inferTags :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) +inferTags ppr_opts !for_bytecode logger this_mod stg_binds = do + -- pprTraceM "inferTags for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) -- Annotate binders with tag information. let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-} - inferTagsAnal stg_binds + inferTagsAnal for_bytecode stg_binds putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) let export_tag_info = collectExportInfo stg_binds_w_tags @@ -254,10 +273,10 @@ , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) -inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] -inferTagsAnal binds = +inferTagsAnal :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] +inferTagsAnal for_bytecode binds = -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ - snd (mapAccumL inferTagTopBind initEnv binds) + snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) ----------------------- inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen @@ -420,11 +439,12 @@ -- ppr bndr $$ -- ppr (isDeadEndId id) $$ -- ppr sig) - (env', StgNonRec (id, sig) rhs') + (env', StgNonRec (id, out_sig) rhs') where id = getBinderId in_env bndr - env' = extendSigEnv in_env [(id, sig)] - (sig,rhs') = inferTagRhs id in_env rhs + (in_sig,rhs') = inferTagRhs id in_env rhs + out_sig = mkLetSig in_env in_sig + env' = extendSigEnv in_env [(id, out_sig)] inferTagBind in_env (StgRec pairs) = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $ @@ -443,15 +463,18 @@ | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss') | otherwise = go env' out_sigs rhss' where - out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive in_bndrs = in_ids `zip` in_sigs + out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive rhs_env = extendSigEnv go_env in_bndrs (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss) env' = makeTagged go_env anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) - anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs + anaRhs bnd rhs = + let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs + in (mkLetSig go_env sig_rhs, rhs') + updateBndr :: (Id,TagSig) -> (Id,TagSig) updateBndr (v,sig) = (setIdTagSig v sig, sig) @@ -535,6 +558,15 @@ -- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args) + +-- Adjust let semantics to the targeted backend. +-- See Note [Tag inference for interpreted code] +mkLetSig :: TagEnv p -> TagSig -> TagSig +mkLetSig env in_sig + | for_bytecode = TagSig TagDunno + | otherwise = in_sig + where + for_bytecode = te_bytecode env {- Note [Constructor TagSigs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs --- a/compiler/GHC/Stg/InferTags/Rewrite.hs +++ b/compiler/GHC/Stg/InferTags/Rewrite.hs @@ -32,6 +32,7 @@ import GHC.Core.Type import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (mkLFImported) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -269,13 +270,10 @@ TagTagged -> True TagTuple _ -> True -- Consider unboxed tuples tagged. False -- Imported - | Just con <- (isDataConWorkId_maybe v) - , isNullaryRepDataCon con - -> return True - | Just lf_info <- idLFInfo_maybe v - -> return $ - -- Can we treat the thing as tagged based on it's LFInfo? - case lf_info of + -> return $! + -- Determine whether it is tagged from the LFInfo of the imported id. + -- See Note [The LFInfo of Imported Ids] + case mkLFImported v of -- Function, applied not entered. LFReEntrant {} -> True @@ -292,9 +290,6 @@ LFLetNoEscape {} -- Shouldn't be possible. I don't think we can export letNoEscapes -> True - - | otherwise - -> return False isArgTagged :: StgArg -> RM Bool diff --git a/compiler/GHC/Stg/InferTags/Types.hs b/compiler/GHC/Stg/InferTags/Types.hs --- a/compiler/GHC/Stg/InferTags/Types.hs +++ b/compiler/GHC/Stg/InferTags/Types.hs @@ -54,24 +54,30 @@ type TagSigEnv = IdEnv TagSig data TagEnv p = TE { te_env :: TagSigEnv , te_get :: BinderP p -> Id + , te_bytecode :: !Bool } instance Outputable (TagEnv p) where - ppr te = ppr (te_env te) - + ppr te = for_txt <+> ppr (te_env te) + where + for_txt = if te_bytecode te + then text "for_bytecode" + else text "for_native" getBinderId :: TagEnv p -> BinderP p -> Id getBinderId = te_get -initEnv :: TagEnv 'CodeGen -initEnv = TE { te_env = emptyVarEnv - , te_get = \x -> x} +initEnv :: Bool -> TagEnv 'CodeGen +initEnv for_bytecode = TE { te_env = emptyVarEnv + , te_get = \x -> x + , te_bytecode = for_bytecode } -- | Simple convert env to a env of the 'InferTaggedBinders pass -- with no other changes. makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders makeTagged env = TE { te_env = te_env env - , te_get = fst } + , te_get = fst + , te_bytecode = te_bytecode env } noSig :: TagEnv p -> BinderP p -> (Id, TagSig) noSig env bndr @@ -80,14 +86,18 @@ where var = getBinderId env bndr +-- | Look up a sig in the given env lookupSig :: TagEnv p -> Id -> Maybe TagSig lookupSig env fun = lookupVarEnv (te_env env) fun +-- | Look up a sig in the env or derive it from information +-- in the arg itself. lookupInfo :: TagEnv p -> StgArg -> TagInfo lookupInfo env (StgVarArg var) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc + , not for_bytecode = TagProper | isUnliftedType (idType var) @@ -98,6 +108,7 @@ = info | Just lf_info <- idLFInfo_maybe var + , not for_bytecode = case lf_info of -- Function, tagged (with arity) LFReEntrant {} @@ -117,6 +128,8 @@ | otherwise = TagDunno + where + for_bytecode = te_bytecode env lookupInfo _ (StgLitArg {}) = TagProper diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -50,6 +50,7 @@ -- ^ Should we lint the STG at various stages of the pipeline? , stgPipeline_pprOpts :: !StgPprOpts , stgPlatform :: !Platform + , stgPipeline_forBytecode :: !Bool } newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } @@ -93,7 +94,7 @@ -- annotations (which is used by code generator to compute offsets into closures) ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds' -- See Note [Tag inference for interactive contexts] - ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs + ; inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs } where diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -958,6 +958,8 @@ -------------------------------------------------------------------------------- {- +Note [Unarisation of Void binders and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For arguments (StgArg) and binders (Id) we have two kind of unarisation: - When unarising function arg binders and arguments, we don't want to remove diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -59,13 +59,13 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap import GHC.Data.OrdList import GHC.Data.Maybe -import GHC.Types.Var.Env +import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish import Data.List ( genericReplicate, genericLength, intersperse @@ -106,7 +106,7 @@ (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- Split top-level binds into strings and others. - -- See Note [generating code for top-level string literal bindings]. + -- See Note [Generating code for top-level string literal bindings]. let (strings, lifted_binds) = partitionEithers $ do -- list monad bnd <- binds case bnd of @@ -117,7 +117,7 @@ stringPtrs <- allocateTopStrings interp strings (BcM_State{..}, proto_bcos) <- - runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do + runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) mapM schemeTopBind flattened_binds @@ -128,7 +128,7 @@ "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr proto_bcos))) - cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs) + cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs (case modBreaks of Nothing -> Nothing Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) @@ -148,29 +148,50 @@ interp = hscInterp hsc_env profile = targetProfile dflags +-- | see Note [Generating code for top-level string literal bindings] allocateTopStrings :: Interp -> [(Id, ByteString)] - -> IO [(Var, RemotePtr ())] + -> IO AddrEnv allocateTopStrings interp topStrings = do let !(bndrs, strings) = unzip topStrings ptrs <- interpCmd interp $ MallocStrings strings - return $ zip bndrs ptrs + return $ mkNameEnv (zipWith mk_entry bndrs ptrs) + where + mk_entry bndr ptr = let nm = getName bndr + in (nm, (nm, AddrPtr ptr)) -{- -Note [generating code for top-level string literal bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a summary on how the byte code generator deals with top-level string -literals: +{- Note [Generating code for top-level string literal bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Compilation plan for top-level string literals] +in GHC.Core, the core-to-core optimizer can introduce top-level Addr# +bindings to represent string literals. The creates two challenges for +the bytecode compiler: (1) compiling the bindings themselves, and +(2) compiling references to such bindings. Here is a summary on how +we deal with them: -1. Top-level string literal bindings are separated from the rest of the module. + 1. Top-level string literal bindings are separated from the rest of + the module. Memory for them is allocated immediately, via + interpCmd, in allocateTopStrings, and the resulting AddrEnv is + recorded in the bc_strs field of the CompiledByteCode result. -2. The strings are allocated via interpCmd, in allocateTopStrings + 2. When we encounter a reference to a top-level string literal, we + generate a PUSH_ADDR pseudo-instruction, which is assembled to + a PUSH_UBX instruction with a BCONPtrAddr argument. -3. The mapping from binders to allocated strings (topStrings) are maintained in - BcM and used when generating code for variable references. --} + 3. The loader accumulates string literal bindings from loaded + bytecode in the addr_env field of the LinkerEnv. + 4. The BCO linker resolves BCONPtrAddr references by searching both + the addr_env (to find literals defined in bytecode) and the native + symbol table (to find literals defined in native code). + +This strategy works alright, but it does have one significant problem: +we never free the memory that we allocate for the top-level strings. +In theory, we could explicitly free it when BCOs are unloaded, but +this comes with its own complications; see #22400 for why. For now, +we just accept the leak, but it would nice to find something better. -} + -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator @@ -298,7 +319,7 @@ -- 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 platform (getName id) (toOL [PACK data_con 0, RETURN]) + emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -459,15 +480,14 @@ non_void VoidRep = False non_void _ = True ret <- case filter non_void reps of - -- use RETURN_UBX for unary representations - [] -> return (unitOL $ RETURN_UNLIFTED V) - [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep)) + -- use RETURN for nullary/unary representations + [] -> return (unitOL $ RETURN V) + [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) -- otherwise use RETURN_TUPLE with a tuple descriptor nv_reps -> do - let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps - args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets - tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs) - return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL` + let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps + tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) + return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE return ( mkSlideB platform szb (d - s) -- clear to sequel @@ -484,7 +504,11 @@ profile <- getProfile let platform = profilePlatform profile arg_ty e = primRepCmmType platform (atomPrimRep e) - (tuple_info, tuple_components) = layoutTuple profile d arg_ty es + (call_info, tuple_components) = layoutNativeCall profile + NativeTupleReturn + d + arg_ty + es go _ pushes [] = return (reverse pushes) go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a massert (off == dd + szb) @@ -492,7 +516,7 @@ pushes <- go d [] tuple_components ret <- returnUnliftedReps d s - (wordsToBytes platform $ tupleSize tuple_info) + (wordsToBytes platform $ nativeCallSize call_info) (map atomPrimRep es) return (mconcat pushes `appOL` ret) @@ -502,7 +526,7 @@ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x []) - | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x) + | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e @@ -648,17 +672,17 @@ -- Case 1 schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty) = if isSupportedCConv ccall_spec - then generateCCall d s p ccall_spec result_ty (reverse args) + then generateCCall d s p ccall_spec result_ty args else unsupportedCConvException schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = doTailCall d s p (primOpId op) (reverse args) -schemeT _d _s _p (StgOpApp StgPrimCallOp{} _args _ty) - = unsupportedCConvException +schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) + = generatePrimCall d s p label (Just unit) result_ty args - -- Case 2: Unboxed tuple schemeT d s p (StgConApp con _cn args _tys) + -- Case 2: Unboxed tuple | isUnboxedTupleDataCon con || isUnboxedSumDataCon con = returnUnboxedTuple d s p args @@ -667,7 +691,7 @@ = do alloc_con <- mkConAppCode d s p con args platform <- profilePlatform <$> getProfile return (alloc_con `appOL` - mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN) + mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) -- Case 4: Tail call of function schemeT d s p (StgApp fn args) @@ -807,14 +831,11 @@ -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. + non_void_arg_reps = non_void (typeArgReps platform bndr_ty) ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 - ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty) - - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) - profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp @@ -823,7 +844,8 @@ -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is - -- on top of the itbl. + -- on top of the itbl; see Note [Return convention for non-tuple values] + -- for details. ret_frame_size_b :: StackDepth ret_frame_size_b | ubx_tuple_frame = (if profiling then 5 else 4) * wordSize platform @@ -837,21 +859,20 @@ -- The size of the return frame info table pointer if one exists unlifted_itbl_size_b :: StackDepth unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform - | ubx_frame = wordSize platform | otherwise = 0 - (bndr_size, tuple_info, args_offsets) + (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) - (tuple_info, args_offsets) = - layoutTuple profile 0 bndr_ty bndr_reps - in ( wordsToBytes platform (tupleSize tuple_info) - , tuple_info + (call_info, args_offsets) = + layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps + in ( wordsToBytes platform (nativeCallSize call_info) + , call_info , args_offsets ) | otherwise = ( wordsToBytes platform (idSizeW platform bndr) - , voidTupleInfo + , voidTupleReturnInfo , [] ) @@ -885,17 +906,18 @@ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = let bndr_ty = primRepCmmType platform . bcIdPrimRep tuple_start = d_bndr - (tuple_info, args_offsets) = - layoutTuple profile - 0 - bndr_ty - bndrs + (call_info, args_offsets) = + layoutNativeCall profile + NativeTupleReturn + 0 + bndr_ty + bndrs stack_bot = d_alts p' = Map.insertList [ (arg, tuple_start - - wordsToBytes platform (tupleSize tuple_info) + + wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets , not (isVoidRep $ bcIdPrimRep arg)] @@ -936,12 +958,26 @@ | otherwise -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) LitAlt l -> case l of - LitNumber LitNumInt i -> DiscrI (fromInteger i) - LitNumber LitNumWord w -> DiscrW (fromInteger w) - LitFloat r -> DiscrF (fromRational r) - LitDouble r -> DiscrD (fromRational r) - LitChar i -> DiscrI (ord i) - _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l) + LitNumber LitNumInt i -> DiscrI (fromInteger i) + LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i) + LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i) + LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i) + LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i) + LitNumber LitNumWord w -> DiscrW (fromInteger w) + LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w) + LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w) + LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w) + LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w) + LitNumber LitNumBigNat _ -> unsupported + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) + LitString {} -> unsupported + LitRubbish {} -> unsupported + LitNullAddr {} -> unsupported + LitLabel {} -> unsupported + where + unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l) maybe_ncons | not isAlgCase = Nothing @@ -967,8 +1003,8 @@ -- unboxed tuples get two more words, the second is a pointer (tuple_bco) (extra_pointers, extra_slots) - | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS - | ubx_tuple_frame = ([1], 2) -- tuple_info, tuple_BCO + | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS + | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO | otherwise = ([], 0) bitmap_size = trunc16W $ fromIntegral extra_slots + @@ -1010,24 +1046,14 @@ p scrut alt_bco' <- emitBc alt_bco if ubx_tuple_frame - then do - let args_ptrs = - map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) - args_offsets - tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs) - return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco - `consOL` scrut_code) - else let push_alts - | not ubx_frame - = PUSH_ALTS alt_bco' - | otherwise - = let unlifted_rep = - case non_void_arg_reps of - [] -> V - [rep] -> rep - _ -> panic "schemeE(StgCase).push_alts" - in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep - in return (push_alts `consOL` scrut_code) + then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) + return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco + `consOL` scrut_code) + else let scrut_rep = case non_void_arg_reps of + [] -> V + [rep] -> rep + _ -> panic "schemeE(StgCase).push_alts" + in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code) -- ----------------------------------------------------------------------------- @@ -1036,14 +1062,15 @@ -- The native calling convention uses registers for tuples, but in the -- bytecode interpreter, all values live on the stack. -layoutTuple :: Profile - -> ByteOff - -> (a -> CmmType) - -> [a] - -> ( TupleInfo -- See Note [GHCi TupleInfo] - , [(a, ByteOff)] -- argument, offset on stack - ) -layoutTuple profile start_off arg_ty reps = +layoutNativeCall :: Profile + -> NativeCallType + -> ByteOff + -> (a -> CmmType) + -> [a] + -> ( NativeCallInfo -- See Note [GHCi TupleInfo] + , [(a, ByteOff)] -- argument, offset on stack + ) +layoutNativeCall profile call_type start_off arg_ty reps = let platform = profilePlatform profile (orig_stk_bytes, pos) = assignArgumentsPos profile 0 @@ -1056,7 +1083,7 @@ -- sort the register parameters by register and add them to the stack regs_order :: Map.Map GlobalReg Int - regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..] + regs_order = Map.fromList $ zip (allArgRegsCover platform) [0..] reg_order :: GlobalReg -> (Int, GlobalReg) reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) @@ -1085,10 +1112,11 @@ get_byte_off _ = panic "GHC.StgToByteCode.layoutTuple get_byte_off" - in ( TupleInfo - { tupleSize = bytesToWords platform (ByteOff new_stk_bytes) - , tupleRegs = regs_set - , tupleNativeStackSize = bytesToWords platform + in ( NativeCallInfo + { nativeCallType = call_type + , nativeCallSize = bytesToWords platform (ByteOff new_stk_bytes) + , nativeCallRegs = regs_set + , nativeCallStackSpillSize = bytesToWords platform (ByteOff orig_stk_bytes) } , sortBy (comparing snd) $ @@ -1096,24 +1124,41 @@ (orig_stk_params ++ map get_byte_off new_stk_params) ) -{- - We use the plain return convention (ENTER/PUSH_ALTS) for - lifted types and unlifted algebraic types. +{- Note [Return convention for non-tuple values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RETURN and ENTER instructions are used to return values. RETURN directly +returns the value at the top of the stack while ENTER evaluates it first (so +RETURN is only used when the result is already known to be evaluated), but the +end result is the same: control returns to the enclosing stack frame with the +result at the top of the stack. - Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect - additional data on the stack. - -} -usePlainReturn :: Type -> Bool -usePlainReturn t - | isUnboxedTupleType t || isUnboxedSumType t = False - | otherwise = typePrimRep t == [LiftedRep] || - (typePrimRep t == [UnliftedRep] && isAlgType t) +The PUSH_ALTS instruction pushes a two-word stack frame that receives a single +lifted value. Its payload is a BCO that is executed when control returns, with +the stack set up as if a RETURN instruction had just been executed: the returned +value is at the top of the stack, and beneath it is the two-word frame being +returned to. It is the continuation BCO’s job to pop its own frame off the +stack, so the simplest possible continuation consists of two instructions: -{- Note [unboxed tuple bytecodes and tuple_BCO] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value + RETURN P -- return the returned value to our caller + +RETURN and PUSH_ALTS are not really instructions but are in fact representation- +polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a +single real instruction, since it is only used to return lifted values, which +are always pointers. + +The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned +value has nullary or unary representation. Returning/receiving an unboxed +tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to +unboxed tuples by Unarise) containing two or more results uses the special +RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return +convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details. + +Note [unboxed tuple bytecodes and tuple_BCO] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to return and receive arbitrary unboxed tuples, respectively. These - instructions use the helper data tuple_BCO and tuple_info. + instructions use the helper data tuple_BCO and call_info. The helper data is used to convert tuples between GHCs native calling convention (object code), which uses stack and registers, and the bytecode @@ -1125,7 +1170,7 @@ ================= Bytecode that returns a tuple first pushes all the tuple fields followed - by the appropriate tuple_info and tuple_BCO onto the stack. It then + by the appropriate call_info and tuple_BCO onto the stack. It then executes the RETURN_TUPLE instruction, which causes the interpreter to push stg_ret_t_info to the top of the stack. The stack (growing down) then looks as follows: @@ -1136,14 +1181,14 @@ tuple_field_2 ... tuple_field_n - tuple_info + call_info tuple_BCO stg_ret_t_info <- Sp If next_frame is bytecode, the interpreter will start executing it. If it's object code, the interpreter jumps back to the scheduler, which in turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native - calling convention using the description in tuple_info, and then jumps + calling convention using the description in call_info, and then jumps to next_frame. @@ -1155,13 +1200,13 @@ tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data: * cont_BCO: the continuation that receives the tuple - * tuple_info: see below + * call_info: see below * tuple_BCO: see below The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE instruction is executed, followed by stg_ctoi_tN_info, with N depending on the number of stack words used by the tuple in the GHC native calling - convention. N is derived from tuple_info. + convention. N is derived from call_info. For example if we expect a tuple with three words on the stack, the stack looks as follows after PUSH_ALTS_TUPLE: @@ -1172,7 +1217,7 @@ cont_free_var_2 ... cont_free_var_n - tuple_info + call_info tuple_BCO cont_BCO stg_ctoi_t3_info <- Sp @@ -1192,24 +1237,23 @@ that is already on the stack. - The tuple_info word + The call_info word =================== - The tuple_info word describes the stack and STG register (e.g. R1..R6, - D1..D6) usage for the tuple. tuple_info contains enough information to + The call_info word describes the stack and STG register (e.g. R1..R6, + D1..D6) usage for the tuple. call_info contains enough information to convert the tuple between the stack-only bytecode and stack+registers GHC native calling conventions. - See Note [GHCi tuple layout] for more details of how the data is packed - in a single word. + See Note [GHCi and native call registers] for more details of how the + data is packed in a single word. -} -tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name -tupleBCO platform info pointers = +tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +tupleBCO platform args_info args = mkProtoBCO platform invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-} - where {- The tuple BCO is never referred to by name, so we can get away @@ -1219,16 +1263,131 @@ -} invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") - -- the first word in the frame is the tuple_info word, + -- the first word in the frame is the call_info word, -- which is not a pointer - bitmap_size = trunc16W $ 1 + tupleSize info - bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $ - map ((+1) . fromIntegral . bytesToWords platform . snd) - (filter fst pointers) + nptrs_prefix = 1 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + body_code = mkSlideW 0 1 -- pop frame header `snocOL` RETURN_TUPLE -- and add it again +primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +primCallBCO platform args_info args = + mkProtoBCO platform invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-is alts-} + where + {- + The primcall BCO is never referred to by name, so we can get away + with using a fake name here. We will need to change this if we want + to save some memory by sharing the BCO between places that have + the same tuple shape + -} + invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") + + -- The first two words in the frame (after the BCO) are the call_info word + -- and the pointer to the Cmm function being called. Neither of these is a + -- pointer that should be followed by the garbage collector. + nptrs_prefix = 2 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + + -- if the primcall BCO is ever run it's a bug, since the BCO should only + -- be pushed immediately before running the PRIMCALL bytecode instruction, + -- which immediately leaves the interpreter to jump to the stg_primcall_info + -- Cmm function + body_code = unitOL CASEFAIL + +-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by +-- some number of arguments. +mkStackBitmap + :: Platform + -> WordOff + -- ^ The number of nonpointer words that prefix the arguments. + -> NativeCallInfo + -> [(PrimRep, ByteOff)] + -- ^ The stack layout of the arguments, where each offset is relative to the + -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned, + -- and the list must be sorted in order of ascending offset (i.e. bottom to top). + -> (Word16, [StgWord]) +mkStackBitmap platform nptrs_prefix args_info args + = (bitmap_size, bitmap) + where + bitmap_size = trunc16W $ nptrs_prefix + arg_bottom + bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets + + arg_bottom = nativeCallSize args_info + ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset) + $ mapMaybe get_ptr_offset args + + get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff + get_ptr_offset (rep, byte_offset) + | isFollowableArg (toArgRep platform rep) = Just byte_offset + | otherwise = Nothing + + convert_arg_offset :: ByteOff -> WordOff + convert_arg_offset arg_offset = + -- The argument offsets are relative to `arg_bottom`, but + -- `intsToReverseBitmap` expects offsets from the top, so we need to flip + -- them around. + nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset) + -- ----------------------------------------------------------------------------- +-- Deal with a primitive call to native code. + +generatePrimCall + :: StackDepth + -> Sequel + -> BCEnv + -> CLabelString -- where to call + -> Maybe Unit + -> Type + -> [StgArg] -- args (atoms) + -> BcM BCInstrList +generatePrimCall d s p target _mb_unit _result_ty args + = do + profile <- getProfile + let + platform = profilePlatform profile + + non_void VoidRep = False + non_void _ = True + + nv_args :: [StgArg] + nv_args = filter (non_void . argPrimRep) args + + (args_info, args_offsets) = + layoutNativeCall profile + NativePrimCall + 0 + (primRepCmmType platform . argPrimRep) + nv_args + + prim_args_offsets = mapFst argPrimRep args_offsets + shifted_args_offsets = mapSnd (+ d) args_offsets + + push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 + push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1 + {- + compute size to move payload (without stg_primcall_info header) + + size of arguments plus three words for: + - function pointer to the target + - call_info word + - BCO to describe the stack frame + -} + szb = wordsToBytes platform (nativeCallSize args_info + 3) + go _ pushes [] = return (reverse pushes) + go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a + massert (off == dd + szb) + go (dd + szb) (push:pushes) cs + push_args <- go d [] shifted_args_offsets + args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets) + return $ mconcat push_args `appOL` + (push_target `consOL` + push_info `consOL` + PUSH_BCO args_bco `consOL` + (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) + +-- ----------------------------------------------------------------------------- -- Deal with a CCall. -- Taggedly push the args onto the stack R->L, @@ -1245,11 +1404,17 @@ -> Type -> [StgArg] -- args (atoms) -> BcM BCInstrList -generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l +generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args + | (StaticTarget _ label mb_unit _) <- target + = generatePrimCall d0 s p label mb_unit result_ty args + | otherwise + = panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets" +generateCCall d0 s p (CCallSpec target cconv safety) result_ty args = do profile <- getProfile let + args_r_to_l = reverse args platform = profilePlatform profile -- useful constants addr_size_b :: ByteOff @@ -1426,7 +1591,7 @@ -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) - `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep) + `snocOL` RETURN (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` @@ -1540,7 +1705,6 @@ The code we generate is this: push arg - push bogus-word TESTEQ_I 0 L1 PUSH_G @@ -1558,13 +1722,6 @@ L_exit: SLIDE 1 n ENTER - -The 'bogus-word' push is because TESTEQ_I expects the top of the stack -to have an info-table, and the next word to have the value to be -tested. This is very weird, but it's the way it is right now. See -Interpreter.c. We don't actually need an info-table here; we just -need to have the argument to be one-from-top on the stack, hence pushing -a 1-word null. See #8383. -} @@ -1590,14 +1747,10 @@ slide_ws = bytesToWords platform (d - s + arg_bytes) return (push_arg - `appOL` unitOL (PUSH_UBX LitNullAddr 1) - -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, LABEL label_exit ] - `appOL` mkSlideW 1 (slide_ws + 1) - -- "+1" to account for bogus word - -- (see Note [Implementing tagToEnum#]) + `appOL` mkSlideW 1 slide_ws `appOL` unitOL ENTER) where mkStep l_exit (my_label, next_label, n, name_for_n) @@ -1663,28 +1816,27 @@ -- slots on to the top of the stack. | otherwise -- var must be a global variable - = do topStrings <- getTopStrings - platform <- targetPlatform <$> getDynFlags - case lookupVarEnv topStrings var of - Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $ - fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr - Nothing - -- PUSH_G doesn't tag constructors. So we use PACK here - -- if we are dealing with nullary constructor. - | Just con <- isDataConWorkId_maybe var - -> do - massert (sz == wordSize platform) - massert (isNullaryRepDataCon con) - return (unitOL (PACK con 0), sz) - | otherwise - -> do - let - massert (sz == wordSize platform) - return (unitOL (PUSH_G (getName var)), sz) - where - !sz = idSizeCon platform var + = do platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform var + massert (szb == wordSize platform) + -- PUSH_G doesn't tag constructors. So we use PACK here + -- if we are dealing with nullary constructor. + case isDataConWorkId_maybe var of + Just con -> do + massert (isNullaryRepDataCon con) + return (unitOL (PACK con 0), szb) + Nothing + -- see Note [Generating code for top-level string literal bindings] + | isUnliftedType (idType var) -> do + massert (idType var `eqType` addrPrimTy) + return (unitOL (PUSH_ADDR (getName var)), szb) + + | otherwise -> do + return (unitOL (PUSH_G (getName var)), szb) + + pushAtom _ _ (StgLitArg lit) = pushLiteral True lit pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff) @@ -1840,14 +1992,30 @@ notd_ways = sortBy (comparing fst) not_defaults testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label + testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label + testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label + testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label + testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label + testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label + testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label testLT (DiscrF i) fail_label = TESTLT_F i fail_label testLT (DiscrD i) fail_label = TESTLT_D i fail_label testLT (DiscrP i) fail_label = TESTLT_P i fail_label testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label + testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label + testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label + testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label + testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label + testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label + testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label @@ -1860,7 +2028,15 @@ | otherwise = case fst (head notd_ways) of DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound ) + DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound ) + DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound ) + DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound ) DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound ) + DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound ) + DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound ) + DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound ) DiscrF _ -> ( DiscrF minF, DiscrF maxF ) DiscrD _ -> ( DiscrD minD, DiscrD maxD ) DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) @@ -1896,7 +2072,15 @@ -- Describes case alts data Discr = DiscrI Int + | DiscrI8 Int8 + | DiscrI16 Int16 + | DiscrI32 Int32 + | DiscrI64 Int64 | DiscrW Word + | DiscrW8 Word8 + | DiscrW16 Word16 + | DiscrW32 Word32 + | DiscrW64 Word64 | DiscrF Float | DiscrD Double | DiscrP Word16 @@ -1905,7 +2089,15 @@ instance Outputable Discr where ppr (DiscrI i) = int i + ppr (DiscrI8 i) = text (show i) + ppr (DiscrI16 i) = text (show i) + ppr (DiscrI32 i) = text (show i) + ppr (DiscrI64 i) = text (show i) ppr (DiscrW w) = text (show w) + ppr (DiscrW8 w) = text (show w) + ppr (DiscrW16 w) = text (show w) + ppr (DiscrW32 w) = text (show w) + ppr (DiscrW64 w) = text (show w) ppr (DiscrF f) = text (show f) ppr (DiscrD d) = text (show d) ppr (DiscrP i) = ppr i @@ -1954,7 +2146,7 @@ isSupportedCConv (CCallSpec _ cconv _) = case cconv of CCallConv -> True -- we explicitly pattern match on every StdCallConv -> True -- convention to ensure that a warning - PrimCallConv -> False -- is triggered when a new one is added + PrimCallConv -> True -- is triggered when a new one is added JavaScriptCallConv -> False CApiConv -> True @@ -2012,8 +2204,6 @@ -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints , breakInfo :: IntMap CgBreakInfo - , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals - -- See Note [generating code for top-level string literal bindings]. } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) @@ -2024,11 +2214,10 @@ return (st, x) runBc :: HscEnv -> Module -> Maybe ModBreaks - -> IdEnv (RemotePtr ()) -> BcM r -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks topStrings (BcM m) - = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings) +runBc hsc_env this_mod modBreaks (BcM m) + = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -2096,9 +2285,6 @@ getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st) - -getTopStrings :: BcM (IdEnv (RemotePtr ())) -getTopStrings = BcM $ \st -> return (st, topStrings st) tickFS :: FastString tickFS = fsLit "ticked" diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -265,22 +265,124 @@ -- Use the LambdaFormInfo from the interface lf_info Nothing - -- Interface doesn't have a LambdaFormInfo, make a conservative one from - -- the type. - | Just con <- isDataConWorkId_maybe id - , isNullaryRepDataCon con - -> LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - + -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type. + -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed! | arity > 0 -> LFReEntrant TopLevel arity True ArgUnknown + | Just con <- isDataConId_maybe id + -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types + -- and Note [The LFInfo of Imported Ids] below + -> assert (hasNoNonZeroWidthArgs con) $ + LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor + | otherwise -> mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id + hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys +{- +Note [The LFInfo of Imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Conveying CAF-info and LFInfo between modules] and +Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the +LambdaFormInfo records the details of a closure representation and is often, +when optimisations are enabled, serialized to the interface of a module. + +In particular, the `lfInfo` field of the `IdInfo` field of an `Id` +* For Ids defined in this module: is `Nothing` +* For imported Ids: + * is (Just lf_info) if the LFInfo was serialised into the interface file + (typically, when the exporting module was compiled with -O) + * is Nothing if it wasn't serialised + +However, when an interface doesn't have a LambdaFormInfo for some imported Id +(so that its `lfInfo` field is `Nothing`), we can conservatively create one +using `mkLFImported`. + +The LambdaFormInfo we give an Id is used in determining how to tag its pointer +(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as +faithfully as possible or otherwise risk having pointers incorrectly tagged, +which can lead to performance issues and even segmentation faults (see #23231 +and #23146). In particular, saturated data constructor applications *must* be +unambiguously given `LFCon`, and the invariant + + If the LFInfo (serialised or built with mkLFImported) says LFCon, then it + really is a static data constructor, and similar for LFReEntrant + +must be upheld. + +In `mkLFImported`, we make a conservative approximation to the real +LambdaFormInfo as follows: + +(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are +tagged (by `litIdInfo`) with the corresponding arity. + - This is also true of data con wrappers and workers with arity > 0, + regardless of the runtime relevance of the arguments + - For example, `Just :: a -> Maybe a` is given `LFReEntrant` + and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too + +(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because +they are fully saturated data constructor applications and pointers to them +should be tagged with the constructor index. + +(2.1) A datacon *wrapper* with zero arity must be a fully saturated application +of the worker to zero-width arguments only (which are dropped after unarisation) + +(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes +no arguments whatsoever (not even zero-width args) + +To ensure we properly give `LFReEntrant` to data constructors with some arity, +and `LFCon` only to data constructors with zero arity, we must first check for +`arity > 0` and only afterwards `isDataConId` -- the order of the guards in +`mkLFImported` is quite important. + +As an example, consider the following data constructors: + + data T1 a where + TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a + + data T2 a where + TCon2 :: {-# UNPACK #-} !() -> T2 a + + data T3 a where + TCon3 :: T3 '[] + +`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while +the worker has an unlifted equality argument, which is zero-width. + +`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width, +while the worker has no arguments. + +`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument; +their Core representation: + + $WTCon3 :: T3 '[] + $WTCon3 = TCon3 @[] + + TCon3 :: forall (a :: * -> *). (a ~# []) => T a + TCon3 = /\a. \(co :: a~#[]). TCon3 co + +For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they +both have arity == 1. + +For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 +while the worker is `LFCon` since its arity == 0 + +For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the +worker `LFReEntrant` since its arity == 1 + +One might think we could give *workers* with only zero-width-args the `LFCon` +LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. +However, these workers, albeit rarely used, are unambiguously functions +-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. +See also the discussion in #23158. + +-} + ------------- mkLFStringLit :: LambdaFormInfo mkLFStringLit = LFUnlifted @@ -309,8 +411,7 @@ -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the --- tagging strategy. See Note [Data constructor dynamic tags] in --- rts/Interpreter.c +-- tagging strategy; see tagConstr in rts/Interpreter.c. isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -82,8 +82,8 @@ mkRhsInit platform reg lf_info expr = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) +-- | Returns a 'CmmExpr' for the *tagged* pointer idInfoToAmode :: CgIdInfo -> CmmExpr --- Returns a CmmExpr for the *tagged* pointer idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc @@ -150,7 +150,7 @@ in return $ litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else - cgLookupPanic id -- Bug + cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} -- | Retrieve cg info for a name if it already exists. diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -8,15 +8,17 @@ module GHC.StgToCmm.Foreign ( cgForeignCall, - emitPrimCall, emitCCall, + emitPrimCall, + emitCCall, + emitCCallNeverReturns, emitForeignCall, emitSaveThreadState, saveThreadState, emitLoadThreadState, emitSaveRegs, emitRestoreRegs, - emitPushTupleRegs, - emitPopTupleRegs, + emitPushArgRegs, + emitPopArgRegs, loadThreadState, emitOpenNursery, emitCloseNursery, @@ -194,19 +196,33 @@ -} -emitCCall :: [(CmmFormal,ForeignHint)] - -> CmmExpr - -> [(CmmActual,ForeignHint)] - -> FCode () -emitCCall hinted_results fn hinted_args +emitCCall' :: CmmReturnInfo + -> [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall' ret_info hinted_results fn hinted_args = void $ emitForeignCall PlayRisky results target args where (args, arg_hints) = unzip hinted_args (results, result_hints) = unzip hinted_results target = ForeignTarget fn fc - fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn + fc = ForeignConvention CCallConv arg_hints result_hints ret_info +emitCCall :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall = emitCCall' CmmMayReturn +emitCCallNeverReturns + :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCallNeverReturns = emitCCall' CmmNeverReturns + + emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args = void $ emitForeignCall PlayRisky res (PrimTarget op) args @@ -349,7 +365,7 @@ -- bytecode interpreter. -- -- The "live registers" bitmap corresponds to the list of registers given by --- 'tupleRegsCover', with the least significant bit indicating liveness of +-- 'allArgRegsCover', with the least significant bit indicating liveness of -- the first register in the list. -- -- Each register is saved to a stack slot of one or more machine words, even @@ -362,12 +378,12 @@ -- if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; } -- if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; } -- --- See Note [GHCi tuple layout] +-- See Note [GHCi and native call registers] -emitPushTupleRegs :: CmmExpr -> FCode () -emitPushTupleRegs regs_live = do +emitPushArgRegs :: CmmExpr -> FCode () +emitPushArgRegs regs_live = do platform <- getPlatform - let regs = zip (tupleRegsCover platform) [0..] + let regs = zip (allArgRegsCover platform) [0..] save_arg (reg, n) = let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask @@ -381,11 +397,11 @@ in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg] emit . catAGraphs =<< mapM save_arg (reverse regs) --- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs') -emitPopTupleRegs :: CmmExpr -> FCode () -emitPopTupleRegs regs_live = do +-- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs') +emitPopArgRegs :: CmmExpr -> FCode () +emitPopArgRegs regs_live = do platform <- getPlatform - let regs = zip (tupleRegsCover platform) [0..] + let regs = zip (allArgRegsCover platform) [0..] save_arg (reg, n) = let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -188,9 +188,11 @@ data CgIdInfo = CgIdInfo - { cg_id :: Id -- Id that this is the info for + { cg_id :: Id + -- ^ Id that this is the info for , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc -- CmmExpr for the *tagged* value + , cg_loc :: CgLoc + -- ^ 'CmmExpr' for the *tagged* value } instance OutputableP Platform CgIdInfo where diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -311,7 +311,7 @@ -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) + emitAssign (CmmLocal res) (byteArraySize platform profile arg) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -320,7 +320,7 @@ -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) + emitAssign (CmmLocal res) (byteArraySize platform profile arg) -- #define touchzh(o) /* nothing */ @@ -394,15 +394,10 @@ -- Getting the size of pointer arrays SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg - (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) - (bWord platform)) + emitAssign (CmmLocal res) (ptrArraySize platform profile arg) SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emit $ mkAssign (CmmLocal res) - (cmmLoadIndexW platform arg - (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) - (bWord platform)) + emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg) SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp @@ -2069,7 +2064,7 @@ -> [CmmExpr] -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx + = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2081,7 +2076,7 @@ -> FCode () doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = let alignment = alignmentFromTypes rep idx_rep - in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx + in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2093,7 +2088,7 @@ doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do profile <- getProfile doByteArrayBoundsCheck idx addr rep rep - mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx + mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2107,7 +2102,7 @@ = do profile <- getProfile doByteArrayBoundsCheck idx addr idx_rep rep let alignment = alignmentFromTypes rep idx_rep - mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx + mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2119,15 +2114,15 @@ = do profile <- getProfile platform <- getPlatform doPtrArrayBoundsCheck idx addr - mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx + mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () -doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val +doWriteOffAddrOp castOp idx_ty [] [addr,idx, val] + = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val) doWriteOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" @@ -2136,11 +2131,12 @@ -> [LocalReg] -> [CmmExpr] -> FCode () -doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] +doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal] = do profile <- getProfile platform <- getPlatform + let val = maybeCast castOp rawVal doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val) - mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val + mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2162,8 +2158,7 @@ -- This write barrier is to ensure that the heap writes to the object -- referred to by val have happened before we write val into the array. -- See #12469 for details. - emitPrimCall [] MO_WriteBarrier [] - mkBasicIndexedWrite hdr_size Nothing addr ty idx val + mkBasicIndexedWrite True hdr_size addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: @@ -2171,16 +2166,12 @@ emit $ mkStore ( cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) - (loadArrPtrsSize profile addr)) + (ptrArraySize platform profile addr)) (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr -loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off) - where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) - platform = profilePlatform profile - -mkBasicIndexedRead :: AlignmentSpec +mkBasicIndexedRead :: Bool -- Should this imply an acquire barrier + -> AlignmentSpec -> ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast -> CmmType -- Type of element we are accessing @@ -2189,27 +2180,40 @@ -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> FCode () -mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx - = do platform <- getPlatform - emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx) -mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx +mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx = do platform <- getPlatform - emitAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx]) + let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx + result <- + if barrier + then do + res <- newTemp ty + emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr] + return $ CmmReg (CmmLocal res) + else + return $ CmmLoad addr ty alignment -mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes - -> Maybe MachOp -- Optional value cast + let casted = + case mb_cast of + Just cast -> CmmMachOp cast [result] + Nothing -> result + emitAssign (CmmLocal res) casted + +mkBasicIndexedWrite :: Bool -- Should this imply a release barrier + -> ByteOff -- Initial offset in bytes -> CmmExpr -- Base address -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> CmmExpr -- Value to write -> FCode () -mkBasicIndexedWrite off Nothing base idx_ty idx val +mkBasicIndexedWrite barrier off base idx_ty idx val = do platform <- getPlatform let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty - emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val -mkBasicIndexedWrite off (Just cast) base idx_ty idx val - = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) + addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx + if barrier + then let w = typeWidth idx_ty + op = MO_AtomicWrite w MemOrderRelease + in emitPrimCall [] op [addr, val] + else emitStore' alignment addr val -- ---------------------------------------------------------------------------- -- Misc utils @@ -2237,6 +2241,30 @@ setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr +maybeCast Nothing val = val +maybeCast (Just cast) val = CmmMachOp cast [val] + +ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +ptrArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) + +smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +smallPtrArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) + +byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +byteArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) + + + ------------------------------------------------------------------------------ -- Helpers for translating vector primops. @@ -2482,10 +2510,9 @@ profile <- getProfile platform <- getPlatform - ifNonZero n $ do - let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) - doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8 - doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8 + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1) + emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2) ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off @@ -2548,7 +2575,7 @@ -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes align = - emitMemcpyCall dst_p src_p bytes align + emitCheckedMemcpyCall dst_p src_p bytes align -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -2577,10 +2604,9 @@ profile <- getProfile platform <- getPlatform - ifNonZero n $ do - let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) - doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 - doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (byteArraySize platform profile src) + emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst) let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off @@ -2598,11 +2624,10 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform - ifNonZero bytes $ do - let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) - doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src) src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off - emitMemcpyCall dst_p src_p bytes (mkAlignment 1) + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) -- | Takes a source 'MutableByteArray#', an offset in the source array, a -- destination 'Addr#', and the number of bytes to copy. Copies the given @@ -2619,19 +2644,21 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform - ifNonZero bytes $ do - let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) - doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst) dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off - emitMemcpyCall dst_p src_p bytes (mkAlignment 1) + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) ifNonZero :: CmmExpr -> FCode () -> FCode () ifNonZero e it = do platform <- getPlatform let pred = cmmNeWord platform e (zeroExpr platform) code <- getCode it - emit =<< mkCmmIfThen' pred code (Just False) + emit =<< mkCmmIfThen' pred code (Just True) + -- This function is used for range operation bounds-checks; + -- Most calls to those ops will not have range length zero. + -- ---------------------------------------------------------------------------- -- Setting byte arrays @@ -2644,8 +2671,8 @@ profile <- getProfile platform <- getPlatform - doByteArrayBoundsCheck off ba b8 b8 - doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8 + whenCheckBounds $ ifNonZero len $ + emitRangeBoundsCheck off len (byteArraySize platform profile ba) let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off @@ -2716,7 +2743,7 @@ -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) (wordAlignment platform) @@ -2758,8 +2785,11 @@ dst <- assignTempE dst0 dst_off <- assignTempE dst_off0 - doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src - doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (ptrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (ptrArraySize platform profile dst) -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n @@ -2778,7 +2808,7 @@ -- The base address of the destination card table dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p - (loadArrPtrsSize profile dst) + (ptrArraySize platform profile dst) emitSetCards dst_off dst_cards_p n @@ -2790,7 +2820,7 @@ -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) (wordAlignment platform) @@ -2827,9 +2857,11 @@ src <- assignTempE src0 dst <- assignTempE dst0 - when (n /= 0) $ do - doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src - doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (smallPtrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (smallPtrArraySize platform profile dst) -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n @@ -2924,7 +2956,7 @@ emit $ mkAssign (CmmLocal res_r) (CmmReg arr) --- | Takes and offset in the destination array, the base address of +-- | Takes an offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). The number of elements may not be zero. -- Marks the relevant cards as dirty. @@ -2957,7 +2989,7 @@ profile <- getProfile platform <- getPlatform doSmallPtrArrayBoundsCheck idx addr - mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr + mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr @@ -2973,11 +3005,11 @@ -- Update remembered set for non-moving collector tmp <- newTemp ty - mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx + mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) - emitPrimCall [] MO_WriteBarrier [] -- #12469 - mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val + -- Write barrier needed due to #12469 + mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ @@ -3103,6 +3135,26 @@ (MO_Memcpy (alignmentBytes align)) [ dst, src, n ] +-- | Emit a call to @memcpy@, but check for range +-- overlap when -fcheck-prim-bounds is on. +emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitCheckedMemcpyCall dst src n align = do + whenCheckBounds (getPlatform >>= doCheck) + emitMemcpyCall dst src n align + where + doCheck platform = do + overlapCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) [] + emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False) + where + rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero + checkDiff p q = (p `minus` q) `uLT` n + or = cmmOrWord platform + minus = cmmSubWord platform + uLT = cmmULtWord platform + ne = cmmNeWord platform + zero = zeroExpr platform + -- | Emit a call to @memmove@. emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemmoveCall dst src n align = @@ -3197,50 +3249,68 @@ -- Array bounds checking --------------------------------------------------------------------------- -doBoundsCheck :: CmmExpr -- ^ accessed index - -> CmmExpr -- ^ array size (in elements) - -> FCode () -doBoundsCheck idx sz = do - do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig - platform <- getPlatform - when do_bounds_check (doCheck platform) - where - doCheck platform = do - boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) [] - emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) - where - uGE = cmmUGeWord platform - and = cmmAndWord platform - zero = zeroExpr platform - ne = cmmNeWord platform - isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero +whenCheckBounds :: FCode () -> FCode () +whenCheckBounds a = do + config <- getStgToCmmConfig + case stgToCmmDoBoundsCheck config of + False -> pure () + True -> a --- We want to make sure that the array size computation is pushed into the --- Opt_DoBoundsChecking check to avoid regregressing compiler performance when --- it's disabled. -{-# INLINE doBoundsCheck #-} +emitBoundsCheck :: CmmExpr -- ^ accessed index + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitBoundsCheck idx sz = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + platform <- getPlatform + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let isOutOfBounds = cmmUGeWord platform idx sz + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) +emitRangeBoundsCheck :: CmmExpr -- ^ first accessed index + -> CmmExpr -- ^ number of accessed indices (non-zero) + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitRangeBoundsCheck idx len arrSizeExpr = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + config <- getStgToCmmConfig + platform <- getPlatform + arrSize <- assignTempE arrSizeExpr + -- arrSizeExpr is probably a load we don't want to duplicate + rangeTooLargeReg <- newTemp (bWord platform) + lastSafeIndexReg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $ + cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let + rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg) + lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg) + badStartIndex = (idx `uGT` lastSafeIndex) + isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero + uGT = cmmUGtWord platform + or = cmmOrWord platform + neq = cmmNeWord platform + zero = zeroExpr platform + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + doPtrArrayBoundsCheck :: CmmExpr -- ^ accessed index (in bytes) -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ -> FCode () -doPtrArrayBoundsCheck idx arr = do +doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do profile <- getProfile platform <- getPlatform - let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) - sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) - doBoundsCheck idx sz + emitBoundsCheck idx (ptrArraySize platform profile arr) doSmallPtrArrayBoundsCheck :: CmmExpr -- ^ accessed index (in bytes) -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ -> FCode () -doSmallPtrArrayBoundsCheck idx arr = do +doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do profile <- getProfile platform <- getPlatform - let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) - sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) - doBoundsCheck idx sz + emitBoundsCheck idx (smallPtrArraySize platform profile arr) doByteArrayBoundsCheck :: CmmExpr -- ^ accessed index (in elements) @@ -3248,18 +3318,18 @@ -> CmmType -- ^ indexing type -> CmmType -- ^ element type -> FCode () -doByteArrayBoundsCheck idx arr idx_ty elem_ty = do +doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do profile <- getProfile platform <- getPlatform - let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) - sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) - elem_sz = widthInBytes $ typeWidth elem_ty - idx_sz = widthInBytes $ typeWidth idx_ty - -- Ensure that the last byte of the access is within the array - idx_bytes = cmmOffsetB platform - (cmmMulWord platform idx (mkIntExpr platform idx_sz)) - (elem_sz - 1) - doBoundsCheck idx_bytes sz + let elem_w = typeWidth elem_ty + idx_w = typeWidth idx_ty + elem_sz = mkIntExpr platform $ widthInBytes elem_w + arr_sz = byteArraySize platform profile arr + effective_arr_sz = + cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) + if elem_w == idx_w + then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check + else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) --------------------------------------------------------------------------- -- Pushing to the update remembered set diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -45,6 +45,7 @@ import GHC.Prelude import GHC.Tc.Utils.Monad +import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.Basic @@ -2096,8 +2097,8 @@ newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs + (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs + (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -1095,6 +1095,22 @@ or multi-parameter type classes - an inferred type that includes unboxed tuples +Note [Inferred type with escaping kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check for an inferred type with an escaping kind; e.g. #23051 + forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a +where the kind of the body of the forall mentions `f` and `g` which +are bound by the forall. No no no. + +This check, mkInferredPolyId, is really in the wrong place: +`inferred_poly_ty` doesn't obey the PKTI and it would be better not to +generalise it in the first place; see #20686. But for now it works. + +I considered adjusting the generalisation in GHC.Tc.Solver to directly check for +escaping kind variables; instead, promoting or defaulting them. But that +gets into the defaulting swamp and is a non-trivial and unforced +change, so I have left it alone for now. + Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1184,7 +1200,9 @@ , Nothing <- sig_fn name -- ...with no type signature = setSrcSpanA b_loc $ do { ((co_fn, matches'), rhs_ty') - <- tcInfer $ \ exp_ty -> + <- tcInferFRR (FRRBinder name) $ \ exp_ty -> + -- tcInferFRR: the type of a let-binder must have + -- a fixed runtime rep. See #23176 tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ -- We extend the error context even for a non-recursive -- function so that in type error messages we show the @@ -1206,7 +1224,9 @@ | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , all (isNothing . sig_fn) bndrs = addErrCtxt (patMonoBindsCtxt pat grhss) $ - do { (grhss', pat_ty) <- tcInfer $ \ exp_ty -> + do { (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty -> + -- tcInferFRR: the type of each let-binder must have + -- a fixed runtime rep. See #23176 tcGRHSsPat grhss exp_ty ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -583,7 +583,7 @@ loc = getLocA (dropWildCards hs_ty) ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) +tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ /dev/null @@ -1,194 +0,0 @@ - --- | This module provides an interface for typechecker plugins to --- access select functions of the 'TcM', principally those to do with --- reading parts of the state. -module GHC.Tc.Plugin ( - -- * Basic TcPluginM functionality - TcPluginM, - tcPluginIO, - tcPluginTrace, - unsafeTcPluginTcM, - - -- * Finding Modules and Names - Finder.FindResult(..), - findImportedModule, - lookupOrig, - - -- * Looking up Names in the typechecking environment - tcLookupGlobal, - tcLookupTyCon, - tcLookupDataCon, - tcLookupClass, - tcLookup, - tcLookupId, - - -- * Getting the TcM state - getTopEnv, - getTargetPlatform, - getEnvs, - getInstEnvs, - getFamInstEnvs, - matchFam, - - -- * Type variables - newUnique, - newFlexiTyVar, - isTouchableTcPluginM, - - -- * Zonking - zonkTcType, - zonkCt, - - -- * Creating constraints - newWanted, - newGiven, - newCoercionHole, - - -- * Manipulating evidence bindings - newEvVar, - setEvBind, - ) where - -import GHC.Prelude - -import GHC.Platform (Platform) - -import qualified GHC.Tc.Utils.Monad as TcM -import qualified GHC.Tc.Solver.Monad as TcS -import qualified GHC.Tc.Utils.Env as TcM -import qualified GHC.Tc.Utils.TcMType as TcM -import qualified GHC.Tc.Instance.Family as TcM -import qualified GHC.Iface.Env as IfaceEnv -import qualified GHC.Unit.Finder as Finder - -import GHC.Core.FamInstEnv ( FamInstEnv ) -import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM - , unsafeTcPluginTcM - , liftIO, traceTc ) -import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) ) -import GHC.Tc.Utils.TcMType ( TcTyVar, TcType ) -import GHC.Tc.Utils.Env ( TcTyThing ) -import GHC.Tc.Types.Evidence ( CoercionHole, EvTerm(..) - , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) -import GHC.Types.Var ( EvVar ) - -import GHC.Unit.Module ( ModuleName, Module ) -import GHC.Types.Name ( OccName, Name ) -import GHC.Types.TyThing ( TyThing ) -import GHC.Core.Reduction ( Reduction ) -import GHC.Core.TyCon ( TyCon ) -import GHC.Core.DataCon ( DataCon ) -import GHC.Core.Class ( Class ) -import GHC.Driver.Env ( HscEnv(..) ) -import GHC.Utils.Outputable ( SDoc ) -import GHC.Core.Type ( Kind, Type, PredType ) -import GHC.Types.Id ( Id ) -import GHC.Core.InstEnv ( InstEnvs ) -import GHC.Types.Unique ( Unique ) -import GHC.Types.PkgQual ( PkgQual ) - - --- | Perform some IO, typically to interact with an external tool. -tcPluginIO :: IO a -> TcPluginM a -tcPluginIO a = unsafeTcPluginTcM (liftIO a) - --- | Output useful for debugging the compiler. -tcPluginTrace :: String -> SDoc -> TcPluginM () -tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - - -findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult -findImportedModule mod_name mb_pkg = do - hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg - -lookupOrig :: Module -> OccName -> TcPluginM Name -lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod - - -tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal - -tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon - -tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon - -tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass - -tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcM.tcLookup - -tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId - - -getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcM.getTopEnv - -getTargetPlatform :: TcPluginM Platform -getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform - - -getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcM.getEnvs - -getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs - -getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] - -> TcPluginM (Maybe Reduction) -matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args - -newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcM.newUnique - -newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar - -isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM - --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. -zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType - -zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt - --- | Create a new Wanted constraint with the given 'CtLoc'. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty - = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty) - --- | Create a new given constraint, with the supplied evidence. --- --- This should only be invoked within 'tcPluginSolve'. -newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence -newGiven tc_evbinds loc pty evtm = do - new_ev <- newEvVar pty - setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm) - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } - --- | Create a fresh evidence variable. --- --- This should only be invoked within 'tcPluginSolve'. -newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcM.newEvVar - --- | Create a fresh coercion hole. --- This should only be invoked within 'tcPluginSolve'. -newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole - --- | Bind an evidence variable. --- --- This should only be invoked within 'tcPluginSolve'. -setEvBind :: EvBindsVar -> EvBind -> TcPluginM () -setEvBind tc_evbinds ev_bind = do - unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -7,6 +7,7 @@ unifyWanted, makeSuperClasses, StopOrContinue(..), stopWith, continueWith, andWhenContinue, + rewriteEqEvidence, solveCallStack -- For GHC.Tc.Solver ) where @@ -2302,7 +2303,7 @@ -> MCoercion -- :: kind(rhs) ~N kind(lhs) -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs + = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs ; if | case is_touchable of { Untouchable -> False; _ -> True } , cterHasNoProblem $ checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -22,6 +22,7 @@ import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) import GHC.Core.Class import GHC.Core.TyCon +import GHC.Core.Reduction import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) @@ -1562,7 +1563,7 @@ -> TcType -- RHS -> TcS (StopOrContinue Ct) tryToSolveByUnification work_item ev tv rhs - = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs + = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs , ppr is_touchable ]) @@ -1922,7 +1923,7 @@ | otherwise = do { res <- matchLocalInst pred loc ; case res of - OneInst {} -> chooseInstance work_item res + OneInst {} -> chooseInstance ev res _ -> continueWith work_item } where @@ -1939,20 +1940,44 @@ doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2 -- See Note [Looking up primitive equalities in quantified constraints] - | Just (cls, tys) <- boxEqPred eq_rel t1 t2 - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance work_item - (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - _ -> continueWith work_item } - - | otherwise - = continueWith work_item + = do { ev_binds_var <- getTcEvBindsVar + ; ics <- getInertCans + ; if isWanted ev -- Never look up Givens in quantified constraints + && not (null (inert_insts ics)) -- Shortcut common case + && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] + then try_for_qci + else continueWith work_item} where ev = ctEvidence work_item loc = ctEvLoc ev + role = eqRelRole eq_rel + + try_for_qci -- First try looking for (lhs ~ rhs) + | Just (cls, tys) <- boxEqPred eq_rel t1 t2 + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "final_qci_check:1" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> try_swapping } + | otherwise + = continueWith work_item + + try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) + | Just (cls, tys) <- boxEqPred eq_rel t2 t1 + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "final_qci_check:2" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped + (mkReflRedn role t2) (mkReflRedn role t1) + ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } + _ -> do { traceTcS "final_qci_check:3" (ppr work_item) + ; continueWith work_item }} + | otherwise + = continueWith work_item + mk_eq_ev cls tys mk_ev evs = case (mk_ev evs) of EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) @@ -2185,7 +2210,7 @@ OneInst { cir_what = what } -> do { insertSafeOverlapFailureTcS what work_item ; addSolvedDict what ev cls xis - ; chooseInstance work_item lkup_res } + ; chooseInstance ev lkup_res } _ -> -- NoInstance or NotSure -- We didn't solve it; so try functional dependencies with -- the instance environment, and return @@ -2197,27 +2222,23 @@ doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) -chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct) +chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct) chooseInstance work_item (OneInst { cir_new_theta = theta , cir_what = what , cir_mk_ev = mk_ev }) - = do { traceTcS "doTopReact/found instance for" $ ppr ev + = do { traceTcS "doTopReact/found instance for" $ ppr work_item ; deeper_loc <- checkInstanceOK loc what pred ; checkReductionDepth deeper_loc pred - ; evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then continueWith work_item - -- See Note [Instances in no-evidence implications] - else - do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta - ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" }} + ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) + (ppr work_item) + ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta + ; setEvBindIfWanted work_item (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith work_item "Dict/Top (solved wanted)" } where - ev = ctEvidence work_item - pred = ctEvPred ev - loc = ctEvLoc ev + pred = ctEvPred work_item + loc = ctEvLoc work_item chooseInstance work_item lookup_res = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) @@ -2240,26 +2261,6 @@ = setCtLocOrigin loc (ScOrigin infinity) | otherwise = loc - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) - [W] forall a. m (Int, IntStateT m a) - ~R# - m (Int, StateT Int m a) - -The Given is an ordinary quantified constraint; the Wanted is an implication -equality that arises from - [W] (forall a. t1) ~R# (forall a. t2) - -But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) -we can't generate any term evidence. So we can't actually use that -lovely quantified constraint. Alas! - -This test arranges to ignore the instance-based solution under these -(rare) circumstances. It's sad, but I really don't see what else we can do. --} matchClassInst :: DynFlags -> InertSet diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1250,35 +1250,37 @@ ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs) ppr Untouchable = text "Untouchable" -touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult --- This is the key test for untouchability: +touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType) +-- ^ This is the key test for untouchability: -- See Note [Unification preconditions] in GHC.Tc.Utils.Unify -- and Note [Solve by unification] in GHC.Tc.Solver.Interact +-- +-- Returns a new rhs type, as this function can turn make some metavariables concrete. touchabilityTest flav tv1 rhs | flav /= Given -- See Note [Do not unify Givens] , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1 - = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs - ; if not can_continue_solving - then return Untouchable - else - do { ambient_lvl <- getTcLevel + = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs + ; case continue_solving of + { Nothing -> return (Untouchable, rhs) + ; Just rhs -> + do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $ + nonDetEltsUniqSet $ + tyCoVarsOfType rhs + ; ambient_lvl <- getTcLevel ; given_eq_lvl <- getInnermostGivenEqLevel ; if | tv_lvl `sameDepthAs` ambient_lvl - -> return TouchableSameLevel + -> return (TouchableSameLevel, rhs) | tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities , all (does_not_escape tv_lvl) free_skols -- No skolem escapes - -> return (TouchableOuterLevel free_metas tv_lvl) + -> return (TouchableOuterLevel free_metas tv_lvl, rhs) | otherwise - -> return Untouchable } } + -> return (Untouchable, rhs) } } } | otherwise - = return Untouchable + = return (Untouchable, rhs) where - (free_metas, free_skols) = partition isPromotableMetaTyVar $ - nonDetEltsUniqSet $ - tyCoVarsOfType rhs does_not_escape tv_lvl fv | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv @@ -1702,8 +1704,8 @@ Consider [G] forall a. blah => a ~ T [W] S ~# T -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ -T) in the quantified constraints, and wraps the (boxed) evidence it +Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) +in the quantified constraints, and wraps the (boxed) evidence it gets back in an eq_sel to extract the unboxed (S ~# T). We can't put that term into a coercion, so we add a value binding h = eq_sel (...) @@ -1919,23 +1921,21 @@ -- See Detail (8) of the Note. = do { should_break <- final_check - ; if should_break then do { redn <- go rhs - ; return (Just redn) } - else return Nothing } + ; mapM go should_break } where flavour = ctEvFlavour ev eq_rel = ctEvEqRel ev final_check = case flavour of - Given -> return True + Given -> return $ Just rhs Wanted -- Wanteds work only with a touchable tyvar on the left -- See "Wanted" section of the Note. | TyVarLHS lhs_tv <- lhs -> - do { result <- touchabilityTest Wanted lhs_tv rhs + do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs ; return $ case result of - Untouchable -> False - _ -> True } - | otherwise -> return False + Untouchable -> Nothing + _ -> Just rhs } + | otherwise -> return Nothing -- This could be considerably more efficient. See Detail (5) of Note. go :: TcType -> TcS ReductionN diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -23,6 +23,7 @@ , instDeclCtxt2 , instDeclCtxt3 , tcATDefault + , substATBndrs ) where @@ -38,7 +39,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( piResultTys ) +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin @@ -56,7 +57,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var -import GHC.Types.Var.Env +import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -522,8 +523,7 @@ -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) + = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv' @@ -546,14 +546,73 @@ | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] } + +-- | Apply a substitution to the type variable binders of an associated type +-- family. This is used to compute default instances for associated type +-- families (see 'tcATDefault') as well as @newtype@-derived associated type +-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). +-- +-- As a concrete example, consider the following class and associated type +-- family: +-- +-- @ +-- class C k (a :: k) where +-- type F k a (b :: k) :: Type +-- type F j p q = (Proxy @j p, Proxy @j (q :: j)) +-- @ +-- +-- If a user defines this instance: +-- +-- @ +-- instance C (Type -> Type) Maybe where {} +-- @ +-- +-- Then in order to typecheck the default @F@ instance, we must apply the +-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which +-- are @[k, a, (b :: k)]@. The result should look like this: +-- +-- @ +-- type F (Type -> Type) Maybe (b :: Type -> Type) = +-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) +-- @ +-- +-- Making this work requires some care. There are two cases: +-- +-- 1. If we encounter a type variable in the domain of the substitution (e.g., +-- @k@ or @a@), then we apply the substitution directly. +-- +-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn +-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution +-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). +-- +-- This step is important to do in case there are later occurrences of @b@, +-- which we must ensure have the correct kind. Otherwise, we might end up +-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the +-- default instance, which would be completely wrong. +-- +-- Contrast 'substATBndrs' function with similar substitution functions: +-- +-- * 'substTyVars' does not substitute into the kinds of each type variable, +-- nor does it extend the substitution. 'substTyVars' is meant for occurrences +-- of type variables, whereas 'substATBndr's is meant for binders. +-- +-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, +-- but it does not apply the substitution to the variables themselves. As +-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of +-- 'Type's. +substATBndrs :: TCvSubst -> [TyVar] -> (TCvSubst, [Type]) +substATBndrs = mapAccumL substATBndr where - subst_tv subst tc_tv + substATBndr :: TCvSubst -> TyVar -> (TCvSubst, Type) + substATBndr subst tc_tv + -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) + -- Case (2) in the Haddocks | otherwise - = (extendTvSubst subst tc_tv ty', ty') + = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + tc_tv' = updateTyVarKind (substTy subst) tc_tv warnMissingAT :: Name -> TcM () warnMissingAT name diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -64,6 +64,8 @@ import GHC.Unit.Module +import GHC.Rename.Utils (wrapGenSpan) + import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel @@ -947,10 +949,11 @@ -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc' (WildPat noExtField)] - (mkHsApp (L loc' (HsVar noExtField - (L locn (getName rEC_SEL_ERROR_ID)))) - (L loc' (HsLit noComments msg_lit)))] + [wrapGenSpan (WildPat noExtField)] + (wrapGenSpan + (HsApp noComments + (wrapGenSpan (HsVar noExtField (wrapGenSpan (getName rEC_SEL_ERROR_ID)))) + (wrapGenSpan (HsLit noComments msg_lit))))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -501,8 +502,17 @@ newInferExpType = new_inferExpType Nothing newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR -newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig) +newInferExpTypeFRR frr_orig + = do { th_stage <- getStage + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | Brack _ (TcPending {}) <- th_stage + -> new_inferExpType Nothing + | otherwise + -> new_inferExpType (Just frr_orig) } + new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType new_inferExpType mb_frr_orig = do { u <- newUnique @@ -557,20 +567,28 @@ inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref }) + , ir_ref = ref + , ir_frr = mb_frr }) = do { mb_inferred_ty <- readTcRef ref ; tau <- case mb_inferred_ty of Just ty -> do { ensureMonoType ty -- See Note [inferResultToType] ; return ty } - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - -- See Note [TcLevel of ExpType] + Nothing -> do { tau <- new_meta ; writeMutVar ref (Just tau) ; return tau } ; traceTc "Forcing ExpType to be monomorphic:" (ppr u <+> text ":=" <+> ppr tau) ; return tau } + where + -- See Note [TcLevel of ExpType] + new_meta = case mb_frr of + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } + Just frr -> mdo { rr <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -893,6 +911,13 @@ , mtv_ref = ref , mtv_tclvl = tclvl }) } +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails +newConcreteTvDetailsAtLevel conc_orig tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = ConcreteTv conc_orig + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv = assert (isTcTyVar tv) $ @@ -938,7 +963,7 @@ -------------------- -- Works with both type and kind variables -writeMetaTyVar :: TcTyVar -> TcType -> TcM () +writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar writeMetaTyVar tyvar ty @@ -956,7 +981,7 @@ = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) -------------------- -writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () +writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; -- the ref cell must be for the same tyvar writeMetaTyVarRef tyvar ref ty @@ -1123,6 +1148,13 @@ ; name <- newMetaTyVarName (fsLit "p") ; return (mkTyVarTy (mkTcTyVar name kind details)) } +newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType +newConcreteTyVarAtLevel conc_orig tc_lvl kind + = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl + ; name <- newMetaTyVarName (fsLit "c") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + + {- ********************************************************************* * * Finding variables to quantify over @@ -1826,6 +1858,17 @@ ; writeMetaTyVar tv manyDataConTy ; return True } + | isConcreteTyVar tv + -- We don't want to quantify; but neither can we default to + -- anything sensible. (If it has kind RuntimeRep or Levity, as is + -- often the case, it'll have been caught earlier by earlier + -- cases. So in this exotic situation we just promote. Not very + -- satisfing, but it's very much a corner case: #23051) + -- We should really implement the plan in #20686. + = do { lvl <- getTcLevel + ; _ <- promoteMetaTyVarTo lvl tv + ; return True } + | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it = default_kind_var tv @@ -2240,7 +2283,7 @@ * * ********************************************************************* -} -promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool +promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool -- When we float a constraint out of an implication we must restore -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion @@ -2258,7 +2301,7 @@ = return False -- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: TcTyVarSet -> TcM Bool +promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool promoteTyVarSet tvs = do { tclvl <- getTcLevel ; bools <- mapM (promoteMetaTyVarTo tclvl) $ diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -2055,10 +2055,10 @@ -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles , cterHasNoProblem (checkTyVarEq tv1 ty2) -- See Note [Prevent unification with type families] - = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2 - ; if not can_continue_solving - then not_ok_so_defer - else + = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2 + ; case mb_continue_solving of + { Nothing -> not_ok_so_defer + ; Just ty2 -> do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) @@ -2072,9 +2072,9 @@ then do { writeMetaTyVar tv1 ty2 ; return (mkTcNomReflCo ty2) } - else defer }} -- This cannot be solved now. See GHC.Tc.Solver.Canonical - -- Note [Equalities with incompatible kinds] for how - -- this will be dealt with in the solver + else defer }}} -- This cannot be solved now. See GHC.Tc.Solver.Canonical + -- Note [Equalities with incompatible kinds] for how + -- this will be dealt with in the solver | otherwise = not_ok_so_defer @@ -2094,39 +2094,38 @@ -- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of -- Note [Unification preconditions]; returns True if these conditions -- are satisfied. But see the Note for other preconditions, too. -startSolvingByUnification :: MetaInfo -> TcType -- zonked - -> TcM Bool +startSolvingByUnification :: MetaInfo -> TcType -- zonked + -> TcM (Maybe TcType) startSolvingByUnification _ xi | hasCoercionHoleTy xi -- (COERCION-HOLE) check - = return False + = return Nothing startSolvingByUnification info xi = case info of - CycleBreakerTv -> return False + CycleBreakerTv -> return Nothing ConcreteTv conc_orig -> - do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi + do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi -- NB: makeTypeConcrete has the side-effect of turning -- some TauTvs into ConcreteTvs, e.g. -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ]) -- will write `beta[tau] := beta[conc]`. -- - -- We don't need to track these unifications for the purposes - -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl), - -- as they don't unlock any further progress. + -- We return the new type, so that callers of this function + -- aren't required to zonk. ; case not_conc_reasons of - [] -> return True - _ -> return False } + [] -> return $ Just xi + _ -> return Nothing } TyVarTv -> case tcGetTyVar_maybe xi of - Nothing -> return False + Nothing -> return Nothing Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle - SkolemTv {} -> return True - RuntimeUnk -> return True + SkolemTv {} -> return $ Just xi + RuntimeUnk -> return $ Just xi MetaTv { mtv_info = info } -> case info of - TyVarTv -> return True - _ -> return False - _ -> return True + TyVarTv -> return $ Just xi + _ -> return Nothing + _ -> return $ Just xi swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2 diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon @@ -1771,7 +1772,7 @@ T9198 and #19668. So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type +zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi , ze_tv_env = tv_env , ze_meta_tv_env = mtv_env_ref }) tv @@ -1844,6 +1845,9 @@ | isMultiplicityTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) ; return manyDataConTy } + | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv + -> do { addErr $ TcRnCannotDefaultConcrete origin + ; return (anyTypeOfKind zonked_kind) } | otherwise -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) ; return (anyTypeOfKind zonked_kind) } diff --git a/compiler/GHC/Utils/Monad/State/Lazy.hs b/compiler/GHC/Utils/Monad/State/Lazy.hs deleted file mode 100644 --- a/compiler/GHC/Utils/Monad/State/Lazy.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE PatternSynonyms #-} - --- | A lazy state monad. -module GHC.Utils.Monad.State.Lazy - ( -- * The State monda - State(State) - , state - , evalState - , execState - , runState - -- * Operations - , get - , gets - , put - , modify - ) where - -import GHC.Prelude - -import GHC.Exts (oneShot) - --- | A state monad which is lazy in the state. -newtype State s a = State' { runState' :: s -> (# a, s #) } - deriving (Functor) - -pattern State :: (s -> (# a, s #)) - -> State s a - --- This pattern synonym makes the monad eta-expand, --- which as a very beneficial effect on compiler performance --- See #18202. --- See Note [The one-shot state monad trick] in GHC.Utils.Monad -pattern State m <- State' m - where - State m = State' (oneShot $ \s -> m s) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -state :: (s -> (a, s)) -> State s a -state f = State $ \s -> case f s of - (r, s') -> (# r, s' #) - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib -version: 9.4.5.20230430 +version: 9.4.6.20230808 license: BSD3 license-file: LICENSE category: Development @@ -90,7 +90,7 @@ stm, rts, hpc == 0.6.*, - ghc-lib-parser == 9.4.5.20230430 + ghc-lib-parser == 9.4.6.20230808 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns @@ -132,11 +132,8 @@ ScopedTypeVariables TypeOperators hs-source-dirs: - ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build - libraries/template-haskell libraries/ghc-boot - libraries/ghci compiler autogen-modules: Paths_ghc_lib @@ -546,14 +543,11 @@ GHC.CmmToAsm.PPC.Regs GHC.CmmToAsm.Ppr GHC.CmmToAsm.Reg.Graph - GHC.CmmToAsm.Reg.Graph.Base - GHC.CmmToAsm.Reg.Graph.Coalesce GHC.CmmToAsm.Reg.Graph.Spill GHC.CmmToAsm.Reg.Graph.SpillClean GHC.CmmToAsm.Reg.Graph.SpillCost GHC.CmmToAsm.Reg.Graph.Stats GHC.CmmToAsm.Reg.Graph.TrivColorable - GHC.CmmToAsm.Reg.Graph.X86 GHC.CmmToAsm.Reg.Linear GHC.CmmToAsm.Reg.Linear.AArch64 GHC.CmmToAsm.Reg.Linear.Base @@ -615,7 +609,6 @@ GHC.Data.Graph.Ops GHC.Data.Graph.Ppr GHC.Data.UnionFind - GHC.Driver.Backpack GHC.Driver.CodeOutput GHC.Driver.Config.Cmm GHC.Driver.Config.CmmToAsm @@ -631,11 +624,9 @@ GHC.Driver.GenerateCgIPEStub GHC.Driver.Main GHC.Driver.Make - GHC.Driver.MakeFile GHC.Driver.Pipeline GHC.Driver.Pipeline.Execute GHC.Driver.Pipeline.LogQueue - GHC.HandleEncoding GHC.Hs.Stats GHC.Hs.Syn.Type GHC.HsToCore @@ -677,7 +668,6 @@ GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable GHC.IfaceToCore - GHC.Linker GHC.Linker.Dynamic GHC.Linker.ExtraObj GHC.Linker.Loader @@ -691,7 +681,6 @@ GHC.Llvm.Syntax GHC.Llvm.Types GHC.Parser.Utils - GHC.Platform.Host GHC.Plugins GHC.Rename.Bind GHC.Rename.Doc @@ -705,7 +694,6 @@ GHC.Rename.Splice GHC.Rename.Unbound GHC.Rename.Utils - GHC.Runtime.Debugger GHC.Runtime.Eval GHC.Runtime.Heap.Inspect GHC.Runtime.Loader @@ -785,7 +773,6 @@ GHC.Tc.Instance.FunDeps GHC.Tc.Instance.Typeable GHC.Tc.Module - GHC.Tc.Plugin GHC.Tc.Solver GHC.Tc.Solver.Canonical GHC.Tc.Solver.Interact @@ -813,13 +800,3 @@ GHC.Types.Unique.MemoFun GHC.Unit.Finder GHC.Utils.Asm - GHC.Utils.Monad.State.Lazy - GHCi.CreateBCO - GHCi.InfoTable - GHCi.ObjLink - GHCi.Run - GHCi.Signals - GHCi.StaticPtrTable - GHCi.TH - Language.Haskell.TH.CodeDo - Language.Haskell.TH.Quote diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs +++ /dev/null @@ -1,12 +0,0 @@ -module GHC.Platform.Host where - -import GHC.Platform.ArchOS - -hostPlatformArch :: Arch -hostPlatformArch = ArchX86_64 - -hostPlatformOS :: OS -hostPlatformOS = OSDarwin - -hostPlatformArchOS :: ArchOS -hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -186,6 +186,9 @@ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 +/* Define to 1 if you have the `mingwex' library (-lmingwex). */ +/* #undef HAVE_LIBMINGWEX */ + /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs deleted file mode 100644 --- a/libraries/ghc-boot/GHC/HandleEncoding.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | See GHC #10762 and #15021. -module GHC.HandleEncoding (configureHandleEncoding) where - -import Prelude -- See note [Why do we import Prelude here?] -import GHC.IO.Encoding (textEncodingName) -import System.Environment -import System.IO - --- | Handle GHC-specific character encoding flags, allowing us to control how --- GHC produces output regardless of OS. -configureHandleEncoding :: IO () -configureHandleEncoding = do - mb_val <- lookupEnv "GHC_CHARENC" - case mb_val of - Just "UTF-8" -> do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - _ -> do - -- Avoid GHC erroring out when trying to display unhandled characters - hSetTranslit stdout - hSetTranslit stderr - --- | Change the character encoding of the given Handle to transliterate --- on unsupported characters instead of throwing an exception -hSetTranslit :: Handle -> IO () -hSetTranslit h = do - menc <- hGetEncoding h - case fmap textEncodingName menc of - Just name | '/' `notElem` name -> do - enc' <- mkTextEncoding $ name ++ "//TRANSLIT" - hSetEncoding h enc' - _ -> return () diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs deleted file mode 100644 --- a/libraries/ghci/GHCi/CreateBCO.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} - --- --- (c) The University of Glasgow 2002-2006 --- - --- | Create real byte-code objects from 'ResolvedBCO's. -module GHCi.CreateBCO (createBCOs) where - -import Prelude -- See note [Why do we import Prelude here?] -import GHCi.ResolvedBCO -import GHCi.RemoteTypes -import GHCi.BreakArray -import GHC.Data.SizedSeq - -import System.IO (fixIO) -import Control.Monad -import Data.Array.Base -import Foreign hiding (newArray) -import Unsafe.Coerce (unsafeCoerce) -import GHC.Arr ( Array(..) ) -import GHC.Exts -import GHC.IO -import Control.Exception ( ErrorCall(..) ) - -createBCOs :: [ResolvedBCO] -> IO [HValueRef] -createBCOs bcos = do - let n_bcos = length bcos - hvals <- fixIO $ \hvs -> do - let arr = listArray (0, n_bcos-1) hvs - mapM (createBCO arr) bcos - mapM mkRemoteRef hvals - -createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue -createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian - = throwIO (ErrorCall $ - unlines [ "The endianness of the ResolvedBCO does not match" - , "the systems endianness. Using ghc and iserv in a" - , "mixed endianness setup is not supported!" - ]) -createBCO arr bco - = -#if MIN_VERSION_ghc_prim(0, 7, 0) - do linked_bco <- linkBCO' arr bco -#else - do BCO bco# <- linkBCO' arr bco -#endif - - -- Note [Updatable CAF BCOs] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Why do we need mkApUpd0 here? Otherwise top-level - -- interpreted CAFs don't get updated after evaluation. A - -- top-level BCO will evaluate itself and return its value - -- when entered, but it won't update itself. Wrapping the BCO - -- in an AP_UPD thunk will take care of the update for us. - -- - -- Furthermore: - -- (a) An AP thunk *must* point directly to a BCO - -- (b) A zero-arity BCO *must* be wrapped in an AP thunk - -- (c) An AP is always fully saturated, so we *can't* wrap - -- non-zero arity BCOs in an AP thunk. - -- - -- See #17424. - if (resolvedBCOArity bco > 0) - -#if MIN_VERSION_ghc_prim(0, 7, 0) - then return (HValue (unsafeCoerce linked_bco)) - else case mkApUpd0# linked_bco of { (# final_bco #) -> -#else - then return (HValue (unsafeCoerce# bco#)) - else case mkApUpd0# bco# of { (# final_bco #) -> -#endif - - return (HValue final_bco) } - - -toWordArray :: UArray Int Word64 -> UArray Int Word -toWordArray = amap fromIntegral - -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO -linkBCO' arr ResolvedBCO{..} = do - let - ptrs = ssElts resolvedBCOPtrs - n_ptrs = sizeSS resolvedBCOPtrs - - !(I# arity#) = resolvedBCOArity - - !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array] - - barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b - insns_barr = barr resolvedBCOInstrs - bitmap_barr = barr (toWordArray resolvedBCOBitmap) - literals_barr = barr (toWordArray resolvedBCOLits) - - PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs - IO $ \s -> - case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} - - --- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr -mkPtrsArray arr n_ptrs ptrs = do - marr <- newPtrsArray (fromIntegral n_ptrs) - let - fill (ResolvedBCORef n) i = - writePtrsArrayHValue i (arr ! n) marr -- must be lazy! - fill (ResolvedBCOPtr r) i = do - hv <- localRef r - writePtrsArrayHValue i hv marr - fill (ResolvedBCOStaticPtr r) i = do - writePtrsArrayPtr i (fromRemotePtr r) marr - fill (ResolvedBCOPtrBCO bco) i = do - -#if MIN_VERSION_ghc_prim(0, 7, 0) - bco <- linkBCO' arr bco - writePtrsArrayBCO i bco marr -#else - BCO bco# <- linkBCO' arr bco - writePtrsArrayBCO i bco# marr -#endif - - fill (ResolvedBCOPtrBreakArray r) i = do - BA mba <- localRef r - writePtrsArrayMBA i mba marr - zipWithM_ fill ptrs [0..] - return marr - -data PtrsArr = PtrsArr (MutableArray# RealWorld HValue) - -newPtrsArray :: Int -> IO PtrsArr -newPtrsArray (I# i) = IO $ \s -> - case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #) - -writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO () -writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s -> - case writeArray# arr i hv s of s' -> (# s', () #) - -writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO () -writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s -> - case writeArrayAddr# arr i a# s of s' -> (# s', () #) - --- This is rather delicate: convincing GHC to pass an Addr# as an Any but --- without making a thunk turns out to be surprisingly tricky. -{-# NOINLINE writeArrayAddr# #-} -writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s -writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s - - -#if MIN_VERSION_ghc_prim(0, 7, 0) -writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO () -#else -writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO () -#endif - -writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> - case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #) - - -#if MIN_VERSION_ghc_prim(0, 7, 0) -writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () -#else -data BCO = BCO BCO# -writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () -#endif - -writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> - case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) - -newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO -newBCO instrs lits ptrs arity bitmap = IO $ \s -> - -#if MIN_VERSION_ghc_prim(0, 7, 0) - newBCO# instrs lits ptrs arity bitmap s -#else - case newBCO# instrs lits ptrs arity bitmap s of - (# s1, bco #) -> (# s1, BCO bco #) -#endif - - -{- Note [BCO empty array] - ~~~~~~~~~~~~~~~~~~~~~~ -Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free: -they are 2-word heap objects. So let's make a single empty array and -share it between all BCOs. --} - -data EmptyArr = EmptyArr ByteArray# - -{-# NOINLINE emptyArr #-} -emptyArr :: EmptyArr -emptyArr = unsafeDupablePerformIO $ IO $ \s -> - case newByteArray# 0# s of { (# s, arr #) -> - case unsafeFreezeByteArray# arr s of { (# s, farr #) -> - (# s, EmptyArr farr #) - }} diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc deleted file mode 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ /dev/null @@ -1,419 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} - --- Get definitions for the structs, constants & config etc. -#include "Rts.h" - --- | --- Run-time info table support. This module provides support for --- creating and reading info tables /in the running program/. --- We use the RTS data structures directly via hsc2hs. --- -module GHCi.InfoTable - ( - mkConInfoTable - ) where - -import Prelude hiding (fail) -- See note [Why do we import Prelude here?] - -import Foreign -import Foreign.C -import GHC.Ptr -import GHC.Exts -import GHC.Exts.Heap -import Data.ByteString (ByteString) -import Control.Monad.Fail -import qualified Data.ByteString as BS -import GHC.Platform.Host (hostPlatformArch) -import GHC.Platform.ArchOS - --- NOTE: Must return a pointer acceptable for use in the header of a closure. --- If tables_next_to_code is enabled, then it must point the 'code' field. --- Otherwise, it should point to the start of the StgInfoTable. -mkConInfoTable - :: Bool -- TABLES_NEXT_TO_CODE - -> Int -- ptr words - -> Int -- non-ptr words - -> Int -- constr tag - -> Int -- pointer tag - -> ByteString -- con desc - -> IO (Ptr StgInfoTable) - -- resulting info table is allocated with allocateExecPage(), and - -- should be freed with freeExecPage(). - -mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do - let entry_addr = interpConstrEntry !! ptrtag - code' <- if tables_next_to_code - then Just <$> mkJumpToAddr entry_addr - else pure Nothing - let - itbl = StgInfoTable { - entry = if tables_next_to_code - then Nothing - else Just entry_addr, - ptrs = fromIntegral ptr_words, - nptrs = fromIntegral nonptr_words, - tipe = CONSTR, - srtlen = fromIntegral tag, - code = code' - } - castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc - - --- ----------------------------------------------------------------------------- --- Building machine code fragments for a constructor's entry code - -funPtrToInt :: FunPtr a -> Int -funPtrToInt (FunPtr a) = I## (addr2Int## a) - -mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes -mkJumpToAddr a = case hostPlatformArch of - ArchPPC -> pure $ - -- We'll use r12, for no particular reason. - -- 0xDEADBEEF stands for the address: - -- 3D80DEAD lis r12,0xDEAD - -- 618CBEEF ori r12,r12,0xBEEF - -- 7D8903A6 mtctr r12 - -- 4E800420 bctr - - let w32 = fromIntegral (funPtrToInt a) - hi16 x = (x `shiftR` 16) .&. 0xFFFF - lo16 x = x .&. 0xFFFF - in Right [ 0x3D800000 .|. hi16 w32, - 0x618C0000 .|. lo16 w32, - 0x7D8903A6, 0x4E800420 ] - - ArchX86 -> pure $ - -- Let the address to jump to be 0xWWXXYYZZ. - -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax - -- which is - -- B8 ZZ YY XX WW FF E0 - - let w32 = fromIntegral (funPtrToInt a) :: Word32 - insnBytes :: [Word8] - insnBytes - = [0xB8, byte0 w32, byte1 w32, - byte2 w32, byte3 w32, - 0xFF, 0xE0] - in - Left insnBytes - - ArchX86_64 -> pure $ - -- Generates: - -- jmpq *.L1(%rip) - -- .align 8 - -- .L1: - -- .quad - -- - -- which looks like: - -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 - -- with addr at 10. - -- - -- We need a full 64-bit pointer (we can't assume the info table is - -- allocated in low memory). Assuming the info pointer is aligned to - -- an 8-byte boundary, the addr will also be aligned. - - let w64 = fromIntegral (funPtrToInt a) :: Word64 - insnBytes :: [Word8] - insnBytes - = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, - byte0 w64, byte1 w64, byte2 w64, byte3 w64, - byte4 w64, byte5 w64, byte6 w64, byte7 w64] - in - Left insnBytes - - ArchAlpha -> pure $ - let w64 = fromIntegral (funPtrToInt a) :: Word64 - in Right [ 0xc3800000 -- br at, .+4 - , 0xa79c000c -- ldq at, 12(at) - , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well - , 0x47ff041f -- nop - , fromIntegral (w64 .&. 0x0000FFFF) - , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] - - ArchARM {} -> pure $ - -- Generates Arm sequence, - -- ldr r1, [pc, #0] - -- bx r1 - -- - -- which looks like: - -- 00000000 <.addr-0x8>: - -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr> - -- 4: 11ff2fe1 bx r1 - let w32 = fromIntegral (funPtrToInt a) :: Word32 - in Left [ 0x00, 0x10, 0x9f, 0xe5 - , 0x11, 0xff, 0x2f, 0xe1 - , byte0 w32, byte1 w32, byte2 w32, byte3 w32] - - ArchAArch64 {} -> pure $ - -- Generates: - -- - -- ldr x1, label - -- br x1 - -- label: - -- .quad - -- - -- which looks like: - -- 0: 58000041 ldr x1,