X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FAbsCUtils.lhs;h=fef7bf56a7f30e2ba8cf3430abef33870f92f440;hb=c9a32c38c1d80b5df0f816f57a2d11555b7eadb4;hp=ac75ca1643b71fe44799809ac4dd7b7b9623adbe;hpb=7a236a564b90cd060612e1e979ce7d552da61fa1;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index ac75ca1..fef7bf5 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -12,7 +12,8 @@ module AbsCUtils ( getAmodeRep, mixedTypeLocn, mixedPtrLocn, flattenAbsC, - mkAbsCStmtList + mkAbsCStmtList, + shimFCallArg -- printing/forcing stuff comes from PprAbsC ) where @@ -20,9 +21,13 @@ module AbsCUtils ( #include "../includes/config.h" import AbsCSyn +import Type ( tyConAppTyCon, repType ) +import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon, + mutableArrayPrimTyCon ) import CLabel ( mkMAP_FROZEN_infoLabel ) import Digraph ( stronglyConnComp, SCC(..) ) -import DataCon ( fIRST_TAG, ConTag ) +import DataCon ( fIRST_TAG, dataConTag ) import Literal ( literalPrimRep, mkMachWord, mkMachInt ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import PrimOp ( PrimOp(..) ) @@ -31,17 +36,15 @@ import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), - isDynamicTarget, isCasmTarget ) -import StgSyn ( StgOp(..) ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget ) +import StgSyn ( StgOp(..), stgArgType ) +import CoreSyn ( AltCon(..) ) import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) import Outputable import Panic ( panic ) import FastTypes import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) -import Maybe ( isJust ) - infixr 9 `thenFlt` \end{code} @@ -108,18 +111,14 @@ mkAbsCStmtList' other r = other : r \end{code} \begin{code} -mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC +mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC -mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc - | isJust (nonemptyAbsC deflt_absc) - = CSwitch scrutinee (adjust tagged_alts) deflt_absc - | otherwise - = CSwitch scrutinee (adjust rest) first_alt +mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts) + = CSwitch scrutinee (adjust rest_alts) first_alt where - -- it's ok to convert one of the alts into a default if we don't already have - -- one, because this is an algebraic case and we're guaranteed that the tag - -- will match one of the branches. - ((_,first_alt):rest) = tagged_alts + -- We use the first alt as the default. Either it *is* the DEFAULT, + -- (which is always first if present), or the case is exhaustive, + -- in which case we can use the first as the default anyway -- Adjust the tags in the switch to start at zero. -- This is the convention used by primitive ops which return algebraic @@ -128,8 +127,8 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc -- We also need to convert to Literals to keep the CSwitch happy adjust tagged_alts - = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c) - | (tag, abs_c) <- tagged_alts ] + = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c) + | (DataAlt dc, abs_c) <- tagged_alts ] \end{code} %************************************************************************ @@ -348,8 +347,8 @@ flatAbsC (CSwitch discrim alts deflt) returnFlt ( (tag, alt_heres), alt_tops ) flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _) - | is_dynamic -- Emit a typedef if its a dynamic call - || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls + | is_dynamic -- Emit a typedef if its a dynamic call + || (opt_EmitCExternDecls) -- or we want extern decls = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) where is_dynamic = isDynamicTarget target @@ -429,13 +428,6 @@ flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt) \end{code} -\begin{code} -flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC) -flat_maybe Nothing = returnFlt (Nothing, AbsCNop) -flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) -> - returnFlt (Just heres, tops) -\end{code} - %************************************************************************ %* * \subsection[flat-simultaneous]{Doing things simultaneously} @@ -612,6 +604,7 @@ mkHalfWord_HIADDR res arg let hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) +# if WORDS_BIGENDIAN a_hw_mask1 = CMachOpStmt t_hw_mask1 MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing @@ -619,12 +612,11 @@ mkHalfWord_HIADDR res arg = CMachOpStmt t_hw_mask2 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing final -# if WORDS_BIGENDIAN = CSequential [ a_hw_mask1, a_hw_mask2, CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing ] # else - = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing + final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing # endif in returnFlt final @@ -669,7 +661,7 @@ mk_OSBI_ref offw rep base idx doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx - = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx + = mkBasicIndexedRead 0 maybe_post_read_cast rep res (mkDerefOff WordRep addr fixedHdrSize) idx doIndexOffAddrOp maybe_post_read_cast rep res addr idx = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx @@ -1305,5 +1297,19 @@ translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) translateOp _ _ _ = Nothing +\end{code} + +\begin{code} +shimFCallArg arg amode + | tycon == foreignObjPrimTyCon + = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode] + | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon + = CMacroExpr PtrRep PTRS_ARR_CTS [amode] + | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon + = CMacroExpr AddrRep BYTE_ARR_CTS [amode] + | otherwise = amode + where + -- should be a tycon app, since this is a foreign call + tycon = tyConAppTyCon (repType (stgArgType arg)) \end{code}