From 6c7d2a946a96ed74799cf353f3f62c875f56639b Mon Sep 17 00:00:00 2001 From: Johan Tibell Date: Wed, 8 Jun 2011 14:25:16 +0200 Subject: Use the new memcpy/memmove/memset MachOps Signed-off-by: David Terei --- compiler/codeGen/CgPrimOp.hs | 49 ++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 99e5c26077..f47fbe39c2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -655,7 +655,8 @@ doCopyArrayOp = emitCopyArray copy where -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) - copy _src _dst = emitMemcpyCall + copy _src _dst dst_p src_p bytes live = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -670,8 +671,8 @@ doCopyMutableArrayOp = emitCopyArray copy -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes live) - (emitMemcpyCall dst_p src_p bytes live) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -737,11 +738,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) live emitMemsetCall (cmmOffsetExprW dst_p n) (CmmLit (mkIntCLit 1)) (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) live stmtC $ CmmAssign (CmmLocal res_r) arr where @@ -761,65 +764,63 @@ emitSetCards dst_start dst_cards_start n live = do (CmmLit (mkIntCLit 1)) ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) live where -- Convert an element index to a card index card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) -- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemcpyCall dst src n live = do +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memcpy CCallConv) + (CmmPrim MO_Memcpy) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing - ForeignLabelInExternalPackage IsFunction)) -- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemmoveCall dst src n live = do +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memmove CCallConv) + (CmmPrim MO_Memmove) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing - ForeignLabelInExternalPackage IsFunction)) --- | Emit a call to @memset@. The second argument must fit inside an --- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemsetCall dst c n live = do +-- | Emit a call to @memset@. The second argument must be a word but +-- its value must fit inside an unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memset CCallConv) + (CmmPrim MO_Memset) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing - ForeignLabelInExternalPackage IsFunction)) -- | Emit a call to @allocate@. emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -- cgit v1.2.1 From 790063769da85adefa9ad9194e00f69e6ca6fd5c Mon Sep 17 00:00:00 2001 From: Johan Tibell Date: Thu, 26 May 2011 22:42:04 +0200 Subject: Unroll memcpy in the X86 backend Signed-off-by: David Terei --- compiler/nativeGen/Size.hs | 16 ++++--- compiler/nativeGen/X86/CodeGen.hs | 89 ++++++++++++++++++++++++++++++++++++++- 2 files changed, 97 insertions(+), 8 deletions(-) diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 6b5b1aff59..5d939d7d98 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -12,12 +12,13 @@ -- properly. eg SPARC doesn't care about FF80. -- module Size ( - Size(..), - intSize, - floatSize, - isFloatSize, - cmmTypeSize, - sizeToWidth + Size(..), + intSize, + floatSize, + isFloatSize, + cmmTypeSize, + sizeToWidth, + sizeInBytes ) where @@ -99,5 +100,6 @@ sizeToWidth size FF32 -> W32 FF64 -> W64 FF80 -> W80 - +sizeInBytes :: Size -> Int +sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 090136085c..fcefbd8819 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -55,13 +55,13 @@ import Constants ( wORD_SIZE ) import DynFlags import Control.Monad ( mapAndUnzipM ) +import Data.Bits import Data.Maybe ( catMaybes ) import Data.Int #if WORD_SIZE_IN_BITS==32 import Data.Maybe ( fromJust ) import Data.Word -import Data.Bits #endif sse2Enabled :: NatM Bool @@ -1504,6 +1504,89 @@ genCCall -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +-- Unroll memcpy calls if the source and destination pointers are at +-- least DWORD aligned and the number of bytes to copy isn't too +-- large. Otherwise, call C's memcpy. +genCCall (CmmPrim MO_Memcpy) _ args@[CmmHinted dst _, CmmHinted src _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + return $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r n + where + size = if align .&. 4 /= 0 then II32 else archWordSize + + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV size (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV size (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall (CmmPrim MO_Memset) _ args@[CmmHinted dst _, + CmmHinted (CmmLit (CmmInt c _)) _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + return $ code_dst dst_r `appOL` go dst_r n + where + (size, val) = case align .&. 3 of + 2 -> (II16, c2) + 0 -> (II32, c4) + _ -> (II8, c) + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Integer -> OrdList Instr + go dst i + -- TODO: Add movabs instruction and support 64-bit sets. + | i >= sizeBytes = -- This might be smaller than the below sizes + unitOL (MOV size (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL` + go dst (i - sizeBytes) + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL` + go dst (i - 4) + | i >= 2 = + unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL` + go dst (i - 2) + | i >= 1 = + unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL` + go dst (i - 1) + | otherwise = nilOL + where + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + #if i386_TARGET_ARCH genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL @@ -1874,6 +1957,10 @@ genCCall = panic "X86.genCCAll: not defined" #endif /* x86_64_TARGET_ARCH */ +-- | We're willing to inline and unroll memcpy/memset calls that touch +-- at most these many bytes. This threshold is the same as the one +-- used by GCC and LLVM. +maxInlineSizeThreshold = 128 outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock outOfLineCmmOp mop res args -- cgit v1.2.1 From 4ed2634bf597d7e1fe00709b4556d199ebd66bde Mon Sep 17 00:00:00 2001 From: Dimitrios Vytiniotis Date: Tue, 14 Jun 2011 18:01:36 +0100 Subject: Subtle bug in canonicalization of givens involving type synonyms. Test case is typecheck/should_compile/GivenTypeSynonym.hs --- compiler/typecheck/TcCanonical.lhs | 31 ++++++++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 66a37388f1..07ada2bd04 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -475,7 +475,9 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify canEq fl cv ty1 ty2 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 + | Nothing <- tcView ty1 -- Naked applications ONLY + , Nothing <- tcView ty2 -- See Note [Naked given applications] + , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 = if isWanted fl then do { cv1 <- newCoVar s1 s2 @@ -493,8 +495,12 @@ canEq fl cv ty1 ty2 ; cc2 <- canEq fl cv2 t1 t2 ; return (cc1 `andCCan` cc2) } - else return emptyCCan -- We cannot decompose given applications - -- because we no longer have 'left' and 'right' + else do { traceTcS "canEq/(app case)" $ + text "Ommitting decomposition of given equality between: " + <+> ppr ty1 <+> text "and" <+> ppr ty2 + ; return emptyCCan -- We cannot decompose given applications + -- because we no longer have 'left' and 'right' + } canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, @@ -513,6 +519,25 @@ canEqFailure :: CtFlavor -> EvVar -> TcS CanonicalCts canEqFailure fl cv = return (singleCCan (mkFrozenError fl cv)) \end{code} +Note [Naked given applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + data A a + type T a = A a +and the given equality: + [G] A a ~ T Int +We will reach the case canEq where we do a tcSplitAppTy_maybe, but if +we dont have the guards (Nothing <- tcView ty1) (Nothing <- tcView +ty2) then the given equation is going to fall through and get +completely forgotten! + +What we want instead is this clause to apply only when there is no +immediate top-level synonym; if there is one it will be later on +unfolded by the later stages of canEq. + +Test-case is in typecheck/should_compile/GivenTypeSynonym.hs + + Note [Equality between type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we see an equality of the form s1 t1 ~ s2 t2 we can always split -- cgit v1.2.1 From ef2ac839746750300dc8e96b8accaee8498298d7 Mon Sep 17 00:00:00 2001 From: Johan Tibell Date: Wed, 15 Jun 2011 14:36:13 +0200 Subject: Fix -Werror failure in native code gen --- compiler/nativeGen/X86/CodeGen.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index fcefbd8819..3898f27863 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1507,9 +1507,9 @@ genCCall -- Unroll memcpy calls if the source and destination pointers are at -- least DWORD aligned and the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall (CmmPrim MO_Memcpy) _ args@[CmmHinted dst _, CmmHinted src _, - CmmHinted (CmmLit (CmmInt n _)) _, - CmmHinted (CmmLit (CmmInt align _)) _] +genCCall (CmmPrim MO_Memcpy) _ [CmmHinted dst _, CmmHinted src _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do code_dst <- getAnyReg dst dst_r <- getNewRegNat size @@ -1549,10 +1549,10 @@ genCCall (CmmPrim MO_Memcpy) _ args@[CmmHinted dst _, CmmHinted src _, dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall (CmmPrim MO_Memset) _ args@[CmmHinted dst _, - CmmHinted (CmmLit (CmmInt c _)) _, - CmmHinted (CmmLit (CmmInt n _)) _, - CmmHinted (CmmLit (CmmInt align _)) _] +genCCall (CmmPrim MO_Memset) _ [CmmHinted dst _, + CmmHinted (CmmLit (CmmInt c _)) _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do code_dst <- getAnyReg dst dst_r <- getNewRegNat size @@ -1960,6 +1960,7 @@ genCCall = panic "X86.genCCAll: not defined" -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one -- used by GCC and LLVM. +maxInlineSizeThreshold :: Integer maxInlineSizeThreshold = 128 outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock -- cgit v1.2.1 From 8c2ddecb4d58bc22b3bed220c514ec54091ffcbc Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 15 Jun 2011 14:46:01 +0100 Subject: Port "6c7d2a9 Use the new memcpy/memmove/memset MachOps" to new codegen. Signed-off-by: Edward Z. Yang --- compiler/codeGen/StgCmmPrim.hs | 60 ++++++++++++++++-------------------------- 1 file changed, 23 insertions(+), 37 deletions(-) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index e6dbcec7f9..2cf72270aa 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -730,7 +730,9 @@ doCopyArrayOp = emitCopyArray copy where -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) - copy _src _dst = emitMemcpyCall + copy _src _dst dst_p src_p bytes = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -745,8 +747,8 @@ doCopyMutableArrayOp = emitCopyArray copy -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes, - getCode $ emitMemcpyCall dst_p src_p bytes + getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)), + getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) ] emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall @@ -811,11 +813,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE)) emitMemsetCall (cmmOffsetExprW dst_p n) (CmmLit (mkIntCLit 1)) (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) emit $ mkAssign (CmmLocal res_r) arr where arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + @@ -834,52 +837,35 @@ emitSetCards dst_start dst_cards_start n = do (CmmLit (mkIntCLit 1)) ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) where -- Convert an element index to a card index card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) -- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -emitMemcpyCall dst src n = do - emitCCall +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemcpyCall dst src n align = do + emitPrimCall [ {-no results-} ] - memcpy - [ (dst, AddrHint) - , (src, AddrHint) - , (n, NoHint) - ] - where - memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing - ForeignLabelInExternalPackage IsFunction)) + MO_Memcpy + [ dst, src, n, align ] -- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -emitMemmoveCall dst src n = do - emitCCall +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemmoveCall dst src n align = do + emitPrimCall [ {- no results -} ] - memmove - [ (dst, AddrHint) - , (src, AddrHint) - , (n, NoHint) - ] - where - memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing - ForeignLabelInExternalPackage IsFunction)) + MO_Memmove + [ dst, src, n, align ] -- | Emit a call to @memset@. The second argument must fit inside an -- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -emitMemsetCall dst c n = do - emitCCall +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemsetCall dst c n align = do + emitPrimCall [ {- no results -} ] - memset - [ (dst, AddrHint) - , (c, NoHint) - , (n, NoHint) - ] - where - memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing - ForeignLabelInExternalPackage IsFunction)) + MO_Memset + [ dst, c, n, align ] -- | Emit a call to @allocate@. emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode () -- cgit v1.2.1 From bca6d71bd7d5fbabcdc2e15561dae511424918fc Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 15 Jun 2011 22:07:20 +1000 Subject: Eliminate hardcoded names of D.A.P --- compiler/ghc.cabal.in | 1 - compiler/vectorise/Vectorise/Builtins.hs | 55 +++--- .../vectorise/Vectorise/Builtins/Initialise.hs | 188 +++++++++--------- compiler/vectorise/Vectorise/Builtins/Modules.hs | 10 - compiler/vectorise/Vectorise/Builtins/Prelude.hs | 209 --------------------- compiler/vectorise/Vectorise/Env.hs | 17 +- compiler/vectorise/Vectorise/Monad.hs | 5 +- 7 files changed, 124 insertions(+), 361 deletions(-) delete mode 100644 compiler/vectorise/Vectorise/Builtins/Prelude.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 4ffb915602..841d85e6c0 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -456,7 +456,6 @@ Library Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules - Vectorise.Builtins.Prelude Vectorise.Builtins Vectorise.Monad.Base Vectorise.Monad.Naming diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index 3647a7f875..125d26482e 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -8,32 +8,33 @@ -- civilized panic message if the specified thing cannot be found. -- module Vectorise.Builtins ( - -- * Builtins - Builtins(..), - indexBuiltin, - - -- * Wrapped selectors - selTy, - selReplicate, - selPick, - selTags, - selElements, - sumTyCon, - prodTyCon, - prodDataCon, - combinePDVar, - scalarZip, - closureCtrFun, + -- * Builtins + Builtins(..), + indexBuiltin, + + -- * Wrapped selectors + selTy, + selReplicate, + selPick, + selTags, + selElements, + sumTyCon, + prodTyCon, + prodDataCon, + combinePDVar, + scalarZip, + closureCtrFun, - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, - - -- * Lookup - primMethod, - primPArray + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons, + + -- * Lookup + primMethod, + primPArray ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules import Vectorise.Builtins.Initialise @@ -48,7 +49,8 @@ import Var import Control.Monad --- | Lookup a method function given its name and instance type. +-- |Lookup a method function given its name and instance type. +-- primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var) primMethod tycon method (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) @@ -58,7 +60,8 @@ primMethod tycon method (Builtins { dphModules = mods }) | otherwise = return Nothing --- | Lookup the representation type we use for PArrays that contain a given element type. +-- |Lookup the representation type we use for PArrays that contain a given element type. +-- primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon) primPArray tycon (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 5a6cf88272..9fdf3ba8f5 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -1,14 +1,13 @@ - module Vectorise.Builtins.Initialise ( - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules -import Vectorise.Builtins.Prelude import BasicTypes import PrelNames @@ -30,20 +29,18 @@ import Outputable import Control.Monad import Data.Array -import Data.List - --- | Create the initial map of builtin types and functions. -initBuiltins - :: PackageId -- ^ package id the builtins are in, eg dph-common - -> DsM Builtins +-- |Create the initial map of builtin types and functions. +-- +initBuiltins :: PackageId -- ^ package id the builtins are in, eg dph-common + -> DsM Builtins initBuiltins pkg = do mapM_ load dph_Orphans -- From dph-common:Data.Array.Parallel.PArray.PData -- PData is a type family that maps an element type onto the type -- we use to hold an array of those elements. - pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData") + pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData") -- PR is a type class that holds the primitive operators we can -- apply to array data. Its functions take arrays in terms of PData types. @@ -53,7 +50,7 @@ initBuiltins pkg -- From dph-common:Data.Array.Parallel.PArray.PRepr - preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr") + preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr") paClass <- externalClass dph_PArray_PRepr (fsLit "PA") let paTyCon = classTyCon paClass [paDataCon] = tyConDataCons paTyCon @@ -62,9 +59,9 @@ initBuiltins pkg replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD") emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD") packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD") - combines <- mapM (externalVar dph_PArray_PRepr) - [mkFastString ("combine" ++ show i ++ "PD") - | i <- [2..mAX_DPH_COMBINE]] + combines <- mapM (externalVar dph_PArray_PRepr) + [mkFastString ("combine" ++ show i ++ "PD") + | i <- [2..mAX_DPH_COMBINE]] let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines @@ -73,45 +70,45 @@ initBuiltins pkg -- Scalar is the class of scalar values. -- The dictionary contains functions to coerce U.Arrays of scalars -- to and from the PData representation. - scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar") + scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar") -- From dph-common:Data.Array.Parallel.Lifted.PArray -- A PArray (Parallel Array) holds the array length and some array elements -- represented by the PData type family. - parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray") + parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray") let [parrayDataCon] = tyConDataCons parrayTyCon -- From dph-common:Data.Array.Parallel.PArray.Types - voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") + voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") voidVar <- externalVar dph_PArray_Types (fsLit "void") fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid") - wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") - sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) + wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") + sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) -- from dph-common:Data.Array.Parallel.PArray.PDataInstances pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid") punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit") - closureTyCon <- externalTyCon dph_Closure (fsLit ":->") + closureTyCon <- externalTyCon dph_Closure (fsLit ":->") -- From dph-common:Data.Array.Parallel.Lifted.Unboxed - sel_tys <- mapM (externalType dph_Unboxed) - (numbered "Sel" 2 mAX_DPH_SUM) + sel_tys <- mapM (externalType dph_Unboxed) + (numbered "Sel" 2 mAX_DPH_SUM) - sel_replicates <- mapM (externalFun dph_Unboxed) - (numbered_hash "replicateSel" 2 mAX_DPH_SUM) + sel_replicates <- mapM (externalFun dph_Unboxed) + (numbered_hash "replicateSel" 2 mAX_DPH_SUM) - sel_picks <- mapM (externalFun dph_Unboxed) - (numbered_hash "pickSel" 2 mAX_DPH_SUM) + sel_picks <- mapM (externalFun dph_Unboxed) + (numbered_hash "pickSel" 2 mAX_DPH_SUM) - sel_tags <- mapM (externalFun dph_Unboxed) - (numbered "tagsSel" 2 mAX_DPH_SUM) + sel_tags <- mapM (externalFun dph_Unboxed) + (numbered "tagsSel" 2 mAX_DPH_SUM) - sel_els <- mapM mk_elements - [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + sel_els <- mapM mk_elements + [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] let selTys = listArray (2, mAX_DPH_SUM) sel_tys @@ -123,26 +120,26 @@ initBuiltins pkg - closureVar <- externalVar dph_Closure (fsLit "closure") - applyVar <- externalVar dph_Closure (fsLit "$:") - liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") - liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") + closureVar <- externalVar dph_Closure (fsLit "closure") + applyVar <- externalVar dph_Closure (fsLit "$:") + liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") + liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") - scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") - scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") - scalar_zips <- mapM (externalVar dph_Scalar) - (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) + scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") + scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") + scalar_zips <- mapM (externalVar dph_Scalar) + (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) - closures <- mapM (externalVar dph_Closure) - (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) + closures <- mapM (externalVar dph_Closure) + (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures - liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) - newUnique + liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) + newUnique return $ Builtins { dphModules = mods @@ -221,32 +218,26 @@ initBuiltins pkg -- | Get the mapping of names in the Prelude to names in the DPH library. -- -initBuiltinVars :: Bool -- FIXME - -> Builtins -> DsM [(Var, Var)] -initBuiltinVars compilingDPH (Builtins { dphModules = mods }) +initBuiltinVars :: Builtins -> DsM [(Var, Var)] +initBuiltinVars (Builtins { dphModules = mods }) = do - uvars <- zipWithM externalVar umods ufs - vvars <- zipWithM externalVar vmods vfs cvars <- zipWithM externalVar cmods cfs return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers] ++ zip (map dataConWorkId cons) cvars - ++ zip uvars vvars where - (umods, ufs, vmods, vfs) = if compilingDPH then ([], [], [], []) else unzip4 (preludeVars mods) - (cons, cmods, cfs) = unzip3 (preludeDataCons mods) + (cons, cmods, cfs) = unzip3 (preludeDataCons mods) defaultDataConWorkers :: [DataCon] defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon] + preludeDataCons :: Modules -> [(DataCon, Module, FastString)] + preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) + = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] + where + mk_tup n mod name = (tupleCon Boxed n, mod, name) -preludeDataCons :: Modules -> [(DataCon, Module, FastString)] -preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) - = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] - where - mk_tup n mod name = (tupleCon Boxed n, mod, name) - - --- | Get a list of names to `TyCon`s in the mock prelude. +-- |Get a list of names to `TyCon`s in the mock prelude. +-- initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinTyCons bi = do @@ -260,83 +251,82 @@ initBuiltinTyCons bi : [(tyConName tc, tc) | tc <- dft_tcs] - where defaultTyCons :: DsM [TyCon] - defaultTyCons - = do word8 <- dsLookupTyCon word8TyConName - return [intTyCon, boolTyCon, doubleTyCon, word8] - + where + defaultTyCons :: DsM [TyCon] + defaultTyCons + = do word8 <- dsLookupTyCon word8TyConName + return [intTyCon, boolTyCon, floatTyCon, doubleTyCon, word8] --- | Get a list of names to `DataCon`s in the mock prelude. +-- |Get a list of names to `DataCon`s in the mock prelude. +-- initBuiltinDataCons :: Builtins -> [(Name, DataCon)] initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons] - where defaultDataCons :: [DataCon] - defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] - + where + defaultDataCons :: [DataCon] + defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] --- | Get the names of all buildin instance functions for the PA class. +-- |Get the names of all buildin instance functions for the PA class. +-- initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPAs (Builtins { dphModules = mods }) insts = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA")) - --- | Get the names of all builtin instance functions for the PR class. +-- |Get the names of all builtin instance functions for the PR class. +-- initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPRs (Builtins { dphModules = mods }) insts = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR")) - --- | Get the names of all DPH instance functions for this class. +-- |Get the names of all DPH instance functions for this class. +-- initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] initBuiltinDicts insts cls = map find $ classInstances insts cls where - find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) - | otherwise = pprPanic "Invalid DPH instance" (ppr i) - + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic "Invalid DPH instance" (ppr i) --- | Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- |Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinBoxedTyCons = return . builtinBoxedTyCons - where builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] - builtinBoxedTyCons _ - = [(tyConName intPrimTyCon, intTyCon)] + where + builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] + builtinBoxedTyCons _ + = [(tyConName intPrimTyCon, intTyCon)] --- | Get a list of all scalar functions in the mock prelude. --- -initBuiltinScalars :: Bool - -> Builtins -> DsM [Var] -initBuiltinScalars True _bi = return [] -initBuiltinScalars False bi = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) --- | Lookup some variable given its name and the module that contains it. +-- Auxilliary look up functions ---------------- + +-- Lookup some variable given its name and the module that contains it. +-- externalVar :: Module -> FastString -> DsM Var externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) - --- | Like `externalVar` but wrap the `Var` in a `CoreExpr` +-- Like `externalVar` but wrap the `Var` in a `CoreExpr`. +-- externalFun :: Module -> FastString -> DsM CoreExpr externalFun mod fs = do var <- externalVar mod fs return $ Var var - --- | Lookup some `TyCon` given its name and the module that contains it. +-- Lookup some `TyCon` given its name and the module that contains it. +-- externalTyCon :: Module -> FastString -> DsM TyCon externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) - --- | Lookup some `Type` given its name and the module that contains it. +-- Lookup some `Type` given its name and the module that contains it. +-- externalType :: Module -> FastString -> DsM Type externalType mod fs = do tycon <- externalTyCon mod fs return $ mkTyConApp tycon [] - --- | Lookup some `Class` given its name and the module that contains it. +-- Lookup some `Class` given its name and the module that contains it. +-- externalClass :: Module -> FastString -> DsM Class externalClass mod fs = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) - diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs index 6ea3595d53..c75057129b 100644 --- a/compiler/vectorise/Vectorise/Builtins/Modules.hs +++ b/compiler/vectorise/Vectorise/Builtins/Modules.hs @@ -22,13 +22,8 @@ data Modules , dph_Closure :: Module , dph_Unboxed :: Module - , dph_Combinators :: Module , dph_Scalar :: Module - , dph_Prelude_Int :: Module - , dph_Prelude_Word8 :: Module - , dph_Prelude_Double :: Module - , dph_Prelude_Bool :: Module , dph_Prelude_Tuple :: Module } @@ -48,13 +43,8 @@ dph_Modules pkg , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure") , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed") - , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators") , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") - , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int") - , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8") - , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double") - , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool") , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple") } where mk = mkModule pkg . mkModuleNameFS diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs deleted file mode 100644 index a59f9369aa..0000000000 --- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs +++ /dev/null @@ -1,209 +0,0 @@ - --- WARNING: This module is a temporary kludge. It will soon go away entirely (once --- VECTORISE SCALAR pragmas are fully implemented.) - --- | Mapping of prelude functions to vectorised versions. --- Functions like filterP currently have a working but naive version in GHC.PArr --- During vectorisation we replace these by calls to filterPA, which are --- defined in dph-common Data.Array.Parallel.Lifted.Combinators --- --- As renamer only sees the GHC.PArr functions, if you want to add a new function --- to the vectoriser there has to be a definition for it in GHC.PArr, even though --- it will never be used at runtime. --- -module Vectorise.Builtins.Prelude - ( preludeVars - , preludeScalars) -where -import Vectorise.Builtins.Modules -import PrelNames -import Module -import FastString - - -preludeVars :: Modules - -> [( Module, FastString -- Maps the original variable to the one in the DPH - , Module, FastString)] -- packages that it should be rewritten to. -preludeVars (Modules { dph_Combinators = _dph_Combinators - , dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - -- , dph_Prelude_Double = dph_Prelude_Double - , dph_Prelude_Bool = dph_Prelude_Bool - }) - - = [ - -- Map scalar functions to versions using closures. - mk' dph_Prelude_Int "div" "divV" - , mk' dph_Prelude_Int "mod" "modV" - , mk' dph_Prelude_Int "sqrt" "sqrtV" - , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" - ] - ++ vars_Ord dph_Prelude_Int - ++ vars_Num dph_Prelude_Int - - ++ vars_Ord dph_Prelude_Word8 - ++ vars_Num dph_Prelude_Word8 - ++ - [ mk' dph_Prelude_Word8 "div" "divV" - , mk' dph_Prelude_Word8 "mod" "modV" - , mk' dph_Prelude_Word8 "fromInt" "fromIntV" - , mk' dph_Prelude_Word8 "toInt" "toIntV" - ] - - -- ++ vars_Ord dph_Prelude_Double - -- ++ vars_Num dph_Prelude_Double - -- ++ vars_Fractional dph_Prelude_Double - -- ++ vars_Floating dph_Prelude_Double - -- ++ vars_RealFrac dph_Prelude_Double - ++ - [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA") - , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA") - - , mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV") - , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV") - , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV") - ] - where - mk = (,,,) - mk' mod v v' = mk mod (fsLit v) mod (fsLit v') - - vars_Ord mod - = [ mk' mod "==" "eqV" - , mk' mod "/=" "neqV" - , mk' mod "<=" "leV" - , mk' mod "<" "ltV" - , mk' mod ">=" "geV" - , mk' mod ">" "gtV" - , mk' mod "min" "minV" - , mk' mod "max" "maxV" - , mk' mod "minimumP" "minimumPA" - , mk' mod "maximumP" "maximumPA" - , mk' mod "minIndexP" "minIndexPA" - , mk' mod "maxIndexP" "maxIndexPA" - ] - - vars_Num mod - = [ mk' mod "+" "plusV" - , mk' mod "-" "minusV" - , mk' mod "*" "multV" - , mk' mod "negate" "negateV" - , mk' mod "abs" "absV" - , mk' mod "sumP" "sumPA" - , mk' mod "productP" "productPA" - ] - - -- vars_Fractional mod - -- = [ mk' mod "/" "divideV" - -- , mk' mod "recip" "recipV" - -- ] - -- - -- vars_Floating mod - -- = [ mk' mod "pi" "pi" - -- , mk' mod "exp" "expV" - -- , mk' mod "sqrt" "sqrtV" - -- , mk' mod "log" "logV" - -- , mk' mod "sin" "sinV" - -- , mk' mod "tan" "tanV" - -- , mk' mod "cos" "cosV" - -- , mk' mod "asin" "asinV" - -- , mk' mod "atan" "atanV" - -- , mk' mod "acos" "acosV" - -- , mk' mod "sinh" "sinhV" - -- , mk' mod "tanh" "tanhV" - -- , mk' mod "cosh" "coshV" - -- , mk' mod "asinh" "asinhV" - -- , mk' mod "atanh" "atanhV" - -- , mk' mod "acosh" "acoshV" - -- , mk' mod "**" "powV" - -- , mk' mod "logBase" "logBaseV" - -- ] - -- - -- vars_RealFrac mod - -- = [ mk' mod "fromInt" "fromIntV" - -- , mk' mod "truncate" "truncateV" - -- , mk' mod "round" "roundV" - -- , mk' mod "ceiling" "ceilingV" - -- , mk' mod "floor" "floorV" - -- ] - -- -preludeScalars :: Modules -> [(Module, FastString)] -preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - , dph_Prelude_Double = dph_Prelude_Double - }) - = [ mk dph_Prelude_Int "div" - , mk dph_Prelude_Int "mod" - , mk dph_Prelude_Int "sqrt" - ] - ++ scalars_Ord dph_Prelude_Int - ++ scalars_Num dph_Prelude_Int - - ++ scalars_Ord dph_Prelude_Word8 - ++ scalars_Num dph_Prelude_Word8 - ++ - [ mk dph_Prelude_Word8 "div" - , mk dph_Prelude_Word8 "mod" - , mk dph_Prelude_Word8 "fromInt" - , mk dph_Prelude_Word8 "toInt" - ] - - ++ scalars_Ord dph_Prelude_Double - ++ scalars_Num dph_Prelude_Double - ++ scalars_Fractional dph_Prelude_Double - ++ scalars_Floating dph_Prelude_Double - ++ scalars_RealFrac dph_Prelude_Double - where - mk mod s = (mod, fsLit s) - - scalars_Ord mod - = [ mk mod "==" - , mk mod "/=" - , mk mod "<=" - , mk mod "<" - , mk mod ">=" - , mk mod ">" - , mk mod "min" - , mk mod "max" - ] - - scalars_Num mod - = [ mk mod "+" - , mk mod "-" - , mk mod "*" - , mk mod "negate" - , mk mod "abs" - ] - - scalars_Fractional mod - = [ mk mod "/" - , mk mod "recip" - ] - - scalars_Floating mod - = [ mk mod "pi" - , mk mod "exp" - , mk mod "sqrt" - , mk mod "log" - , mk mod "sin" - , mk mod "tan" - , mk mod "cos" - , mk mod "asin" - , mk mod "atan" - , mk mod "acos" - , mk mod "sinh" - , mk mod "tanh" - , mk mod "cosh" - , mk mod "asinh" - , mk mod "atanh" - , mk mod "acosh" - , mk mod "**" - , mk mod "logBase" - ] - - scalars_RealFrac mod - = [ mk mod "fromInt" - , mk mod "truncate" - , mk mod "round" - , mk mod "ceiling" - , mk mod "floor" - ] diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 97bb5aef69..d70f09affd 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -10,7 +10,6 @@ module Vectorise.Env ( GlobalEnv(..), initGlobalEnv, extendImportedVarsEnv, - extendScalars, setFamEnv, extendFamEnv, extendTyConsEnv, @@ -46,18 +45,18 @@ data Scope a b -- LocalEnv ------------------------------------------------------------------- -- | The local environment. data LocalEnv - = LocalEnv { + = LocalEnv { -- Mapping from local variables to their vectorised and lifted versions. - local_vars :: VarEnv (Var, Var) + local_vars :: VarEnv (Var, Var) -- In-scope type variables. - , local_tyvars :: [TyVar] + , local_tyvars :: [TyVar] -- Mapping from tyvars to their PA dictionaries. - , local_tyvar_pa :: VarEnv CoreExpr + , local_tyvar_pa :: VarEnv CoreExpr -- Local binding name. - , local_bind_name :: FastString + , local_bind_name :: FastString } @@ -163,12 +162,6 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv extendImportedVarsEnv ps genv = genv { global_vars = extendVarEnvList (global_vars genv) ps } --- |Extend the set of scalar variables in an environment. --- -extendScalars :: [Var] -> GlobalEnv -> GlobalEnv -extendScalars vs genv - = genv { global_scalar_vars = extendVarSetList (global_scalar_vars genv) vs } - -- |Set the list of type family instances in an environment. -- setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 73cba88a3b..e690077192 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -65,13 +65,11 @@ initV hsc_env guts info thing_inside Just pkg -> do { -- set up tables of builtin entities - ; let compilingDPH = dphBackend dflags == DPHThis -- FIXME: temporary kludge support ; builtins <- initBuiltins pkg - ; builtin_vars <- initBuiltinVars compilingDPH builtins + ; builtin_vars <- initBuiltinVars builtins ; builtin_tycons <- initBuiltinTyCons builtins ; let builtin_datacons = initBuiltinDataCons builtins ; builtin_boxed <- initBuiltinBoxedTyCons builtins - ; builtin_scalars <- initBuiltinScalars compilingDPH builtins -- set up class and type family envrionments ; eps <- liftIO $ hscEPS hsc_env @@ -83,7 +81,6 @@ initV hsc_env guts info thing_inside -- construct the initial global environment ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside ; let genv = extendImportedVarsEnv builtin_vars - . extendScalars builtin_scalars . extendTyConsEnv builtin_tycons . extendDataConsEnv builtin_datacons . extendPAFunsEnv builtin_pas -- cgit v1.2.1 From 76dbf0ce3db55cd498836c4cd31559fea4aa7be2 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 14 Jun 2011 22:11:01 +0100 Subject: Deprecate the DatatypeContexts extension --- compiler/main/DynFlags.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b49b860a9b..5ce56f5016 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1688,7 +1688,8 @@ xFlags = [ ( "ExplicitForAll", Opt_ExplicitForAll, nop ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), - ( "DatatypeContexts", Opt_DatatypeContexts, nop ), + ( "DatatypeContexts", Opt_DatatypeContexts, + \ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ), ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), ( "RelaxedLayout", Opt_RelaxedLayout, nop ), ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), -- cgit v1.2.1 From be4726edd34422d804b542d42dc0bb1f036ab2dd Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 16 Jun 2011 00:48:49 +0100 Subject: haddock the mtl package when validating This fixes the ghcpkg05 test failure. (ghc-pkg check was complaining because the mtl docs didn't exist). --- validate | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/validate b/validate index 3ca888fba1..0a0677e908 100755 --- a/validate +++ b/validate @@ -95,10 +95,13 @@ $make test_bindist TEST_PREP=YES # bindistdir="bindisttest/install dir" cd libraries/mtl -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build --builddir=dist-bindist -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install --builddir=dist-bindist -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean --builddir=dist-bindist +"$thisdir/$bindistdir/bin/ghc" --make Setup +./Setup configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --with-haddock="$thisdir/$bindistdir/bin/haddock" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" +./Setup build --builddir=dist-bindist +./Setup haddock --builddir=dist-bindist +./Setup install --builddir=dist-bindist +./Setup clean --builddir=dist-bindist +rm -f Setup Setup.exe Setup.hi Setup.o cd $thisdir fi # testsuite-only -- cgit v1.2.1