X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixInfo.lhs;h=bf822e25fd0db9cbbdc6108966ea12a44cc10113;hb=d11e681f219f6e38c2e5bc87adfb66f82de5ea65;hp=b976193ff5e723f1600faa8f695cf82d8e3db26a;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index b976193..bf822e2 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -1,144 +1,173 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - module StixInfo ( - genCodeInfoTable - ) where -import AbsCSyn -import ClosureInfo -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import Stix -import SplitUniq -import Unique -import Unpretty -import Util + genCodeInfoTable, genBitmapInfoTable, + bitmapToIntegers, bitmapIsSmall, livenessIsSmall + + ) where + +#include "HsVersions.h" +#include "../includes/config.h" +#include "NCG.h" + +import AbsCSyn ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT ) +import StgSyn ( SRT(..) ) +import ClosureInfo ( closurePtrsSize, + closureNonHdrSize, closureSMRep, + infoTableLabelFromCI, + closureSRT, closureSemiTag + ) +import PrimRep ( PrimRep(..) ) +import SMRep ( getSMRepClosureTypeInt ) +import Stix -- all of it +import UniqSupply ( returnUs, UniqSM ) +import BitSet ( BitSet, intBS ) +import Maybes ( maybeToBool ) + +import Bits +import Word + +#if __GLASGOW_HASKELL__ >= 404 +import GlaExts ( fromInt ) +#endif \end{code} Generating code for info tables (arrays of data). \begin{code} -static___rtbl = sStLitLbl SLIT("Static___rtbl") -- out here to avoid CAF (sigh) -const___rtbl = sStLitLbl SLIT("Const___rtbl") -charlike___rtbl = sStLitLbl SLIT("CharLike___rtbl") -intlike___rtbl = sStLitLbl SLIT("IntLike___rtbl") -gen_N___rtbl = sStLitLbl SLIT("Gen_N___rtbl") -gen_S___rtbl = sStLitLbl SLIT("Gen_S___rtbl") -gen_U___rtbl = sStLitLbl SLIT("Gen_U___rtbl") -tuple___rtbl = sStLitLbl SLIT("Tuple___rtbl") -data___rtbl = sStLitLbl SLIT("Data___rtbl") -dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl") - genCodeInfoTable - :: {-Target-} - (HeapOffset -> Int) -- needed bit of Target - -> (CAddrMode -> StixTree) -- ditto - -> AbstractC - -> SUniqSM StixTreeList + :: AbstractC + -> UniqSM StixStmtList -genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) = - returnSUs (\xs -> info : lbl : xs) +genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) + = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs) where - info = StData PtrKind table - lbl = StLabel info_lbl - - table = case sm_rep of - StaticRep _ _ -> [ - StInt (toInteger ptrs), - StInt (toInteger size), - upd_code, - static___rtbl, - tag] - - SpecialisedRep ConstantRep _ _ _ -> [ - StCLbl closure_lbl, - upd_code, - const___rtbl, - tag] - - SpecialisedRep CharLikeRep _ _ _ -> [ - upd_code, - charlike___rtbl, - tag] - - SpecialisedRep IntLikeRep _ _ _ -> [ - upd_code, - intlike___rtbl, - tag] - - SpecialisedRep _ _ _ updatable -> - let rtbl = uppBesides ( - if is_selector then - [uppPStr SLIT("Select__"), - uppInt select_word, - uppPStr SLIT("_rtbl")] - else - [uppPStr (case updatable of - SMNormalForm -> SLIT("Spec_N_") - SMSingleEntry -> SLIT("Spec_S_") - SMUpdatable -> SLIT("Spec_U_") - ), - uppInt size, - uppChar '_', - uppInt ptrs, - uppPStr SLIT("_rtbl")]) - in - case updatable of - SMNormalForm -> [upd_code, StLitLbl rtbl, tag] - _ -> [StLitLbl rtbl, tag] - - GenericRep _ _ updatable -> - let rtbl = case updatable of - SMNormalForm -> gen_N___rtbl - SMSingleEntry -> gen_S___rtbl - SMUpdatable -> gen_U___rtbl - in [ - StInt (toInteger ptrs), - StInt (toInteger size), - upd_code, - rtbl, - tag] - - BigTupleRep _ -> [ - tuple___rtbl, - tag] - DataRep _ -> [ - data___rtbl, - tag] - DynamicRep -> [ - dyn___rtbl, - tag] - - PhantomRep -> [ - upd_code, - info_unused, -- no rep table - tag] - - info_lbl = infoTableLabelFromCI cl_info - closure_lbl = closureLabelFromCI cl_info - - sm_rep = closureSMRep cl_info - maybe_selector = maybeSelectorInfo cl_info - is_selector = maybeToBool maybe_selector - (Just (_, select_word)) = maybe_selector - - tag = StInt (toInteger (closureSemiTag cl_info)) - - size = if isSpecRep sm_rep - then closureNonHdrSize cl_info - else hp_rel (closureSizeWithoutFixedHdr cl_info) - ptrs = closurePtrsSize cl_info - - upd_code = amode2stix upd - - info_unused = StInt (-1) - + info_lbl = infoTableLabelFromCI cl_info + + table | needs_srt = srt_label : rest_of_table + | otherwise = rest_of_table + + rest_of_table = + [ + {- par, prof, debug -} + StInt (toInteger layout_info) + , StInt (toInteger type_info) + ] + + -- sigh: building up the info table is endian-dependent. + -- ToDo: do this using .byte and .word directives. + type_info :: Word32 +#ifdef WORDS_BIGENDIAN + type_info = (fromInt closure_type `shiftL` 16) .|. + (fromInt srt_len) +#else + type_info = (fromInt closure_type) .|. + (fromInt srt_len `shiftL` 16) +#endif + srt = closureSRT cl_info + needs_srt = needsSRT srt + + (srt_label,srt_len) + | is_constr + = (StInt 0, tag) + | otherwise + = case srt of + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len) + + maybe_tag = closureSemiTag cl_info + is_constr = maybeToBool maybe_tag + (Just tag) = maybe_tag + + layout_info :: Word32 +#ifdef WORDS_BIGENDIAN + layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs +#else + layout_info = (fromInt ptrs) .|. (fromInt nptrs `shiftL` 16) +#endif + + ptrs = closurePtrsSize cl_info + nptrs = size - ptrs + + size = closureNonHdrSize cl_info + + closure_type = getSMRepClosureTypeInt (closureSMRep cl_info) + + + +genBitmapInfoTable + :: Liveness + -> C_SRT + -> Int + -> Bool -- must include SRT field (i.e. it's a vector) + -> UniqSM StixStmtList + +genBitmapInfoTable liveness srt closure_type include_srt + = returnUs (\xs -> StData PtrRep table : xs) + + where + table = if srt_len == 0 && not include_srt then + rest_of_table + else + srt_label : rest_of_table + + rest_of_table = + [ + {- par, prof, debug -} + layout_info + , StInt (toInteger type_info) + ] + + layout_info = case liveness of + Liveness lbl mask -> + case bitmapToIntegers mask of + [ ] -> StInt 0 + [i] -> StInt i + _ -> StCLbl lbl + + type_info :: Word32 +#ifdef WORDS_BIGENDIAN + type_info = (fromInt closure_type `shiftL` 16) .|. + (fromInt srt_len) +#else + type_info = (fromInt closure_type) .|. + (fromInt srt_len `shiftL` 16) +#endif + + (srt_label,srt_len) = + case srt of + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> + (StIndex DataPtrRep (StCLbl lbl) + (StInt (toInteger off)), len) + +bitmapToIntegers :: [BitSet] -> [Integer] +bitmapToIntegers = bundle . map (toInteger . intBS) + where +#if BYTES_PER_WORD == 4 + bundle = id +#else + bundle [] = [] + bundle is = case splitAt (BYTES_PER_WORD/4) is of + (these, those) -> + ( foldr1 (\x y -> x + 4294967296 * y) + [x `mod` 4294967296 | x <- these] + : bundle those + ) +#endif + +bitmapIsSmall :: [BitSet] -> Bool +bitmapIsSmall bitmap + = case bitmapToIntegers bitmap of + _:_:_ -> False + _ -> True + +livenessIsSmall :: Liveness -> Bool +livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask \end{code}