X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgUtils.hs;h=3861ddf8883e9c6e4465f4c255b22391672e118a;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=02f53c24545ec7d4f8dddd96660617d74835df8b;hpb=95e67967d9abbef73e8d355d0e168759b4ee0590;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 02f53c2..3861ddf 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic @@ -22,12 +29,17 @@ module CgUtils ( callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmUGtWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, cmmOffsetW, cmmOffsetB, cmmOffsetLitW, cmmOffsetLitB, cmmLoadIndexW, + cmmConstrTag, cmmConstrTag1, + + tagForCon, tagCons, isSmallFamily, + cmmUntag, cmmIsTagged, cmmGetTag, addToMem, addToMemE, mkWordCLit, @@ -39,10 +51,11 @@ module CgUtils ( ) where #include "HsVersions.h" -#include "MachRegs.h" +#include "../includes/MachRegs.h" import CgMonad import TyCon +import DataCon import Id import Constants import SMRep @@ -164,6 +177,9 @@ cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] +--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] +--cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -172,6 +188,57 @@ cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e] blankWord :: CmmStatic blankWord = CmmUninitialised wORD_SIZE +-- Tagging -- +-- Tag bits mask +--cmmTagBits = CmmLit (mkIntCLit tAG_BITS) +cmmTagMask = CmmLit (mkIntCLit tAG_MASK) +cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK)) + +-- Used to untag a possibly tagged pointer +-- A static label need not be untagged +cmmUntag e@(CmmLit (CmmLabel _)) = e +-- Default case +cmmUntag e = (e `cmmAndWord` cmmPointerMask) + +cmmGetTag e = (e `cmmAndWord` cmmTagMask) + +-- Test if a closure pointer is untagged +cmmIsTagged e = (e `cmmAndWord` cmmTagMask) + `cmmNeWord` CmmLit zeroCLit + +cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1)) +-- Get constructor tag, but one based. +cmmConstrTag1 e = e `cmmAndWord` cmmTagMask + +{- + The family size of a data type (the number of constructors) + can be either: + * small, if the family size < 2**tag_bits + * big, otherwise. + + Small families can have the constructor tag in the tag + bits. + Big families only use the tag value 1 to represent + evaluatedness. +-} +isSmallFamily fam_size = fam_size <= mAX_PTR_TAG + +tagForCon con = tag + where + con_tag = dataConTagZ con + fam_size = tyConFamilySize (dataConTyCon con) + tag | isSmallFamily fam_size = con_tag + 1 + | otherwise = 1 + +--Tag an expression, to do: refactor, this appears in some other module. +tagCons con expr = cmmOffsetB expr (tagForCon con) + +-- Copied from CgInfoTbls.hs +-- We keep the *zero-indexed* tag in the srt_len field of the info +-- table of a data constructor. +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + ----------------------- -- Making literals @@ -219,11 +286,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr -tagToClosure this_pkg tycon tag +tagToClosure :: TyCon -> CmmExpr -> CmmExpr +tagToClosure tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel this_pkg (tyConName tycon) + lbl = mkClosureTableLabel (tyConName tycon) ------------------------------------------------------------------------- -- @@ -266,24 +333,24 @@ emitIfThenElse cond then_part else_part ; labelC join_id } -emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code emitRtsCallWithVols fun args vols safe = emitRtsCall' [] fun args (Just vols) safe emitRtsCallWithResult :: LocalReg -> MachHint -> LitString - -> [(CmmExpr,MachHint)] -> Bool -> Code + -> [CmmHinted CmmExpr] -> Bool -> Code emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [(res,hint)] fun args Nothing safe + = emitRtsCall' [CmmHinted res hint] fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' - :: CmmHintFormals + :: CmmFormals -> LitString - -> [(CmmExpr,MachHint)] + -> [CmmHinted CmmExpr] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> Code @@ -292,11 +359,11 @@ emitRtsCall' res fun args vols safe = do then getSRTInfo >>= (return . CmmSafe) else return CmmUnsafe stmtsC caller_save - stmtC (CmmCall target res args safety) + stmtC (CmmCall target res args safety CmmMayReturn) stmtsC caller_load where (caller_save, caller_load) = callerSaveVolatileRegs vols - target = CmmForeignCall fun_expr CCallConv + target = CmmCallee fun_expr CCallConv fun_expr = mkLblExpr (mkRtsCodeLabel fun) ----------------------------------------------------------------------------- @@ -476,15 +543,13 @@ baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 baseRegOffset GCFun = oFFSET_stgGCFun -#ifdef DEBUG baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" baseRegOffset _ = panic "baseRegOffset:other" -#endif ------------------------------------------------------------------------- -- --- Strings gnerate a top-level data block +-- Strings generate a top-level data block -- ------------------------------------------------------------------------- @@ -493,7 +558,7 @@ emitDataLits :: CLabel -> [CmmLit] -> Code emitDataLits lbl lits = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph -- Emit a data-segment data block mkDataLits lbl lits = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) @@ -508,7 +573,7 @@ emitRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph mkRODataLits lbl lits = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData @@ -554,10 +619,10 @@ assignPtrTemp e ; return (CmmReg (CmmLocal reg)) } newNonPtrTemp :: MachRep -> FCode LocalReg -newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) } +newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindNonPtr) } newPtrTemp :: MachRep -> FCode LocalReg -newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) } +newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindPtr) } ------------------------------------------------------------------------- @@ -927,6 +992,7 @@ getSRTInfo = do -- TODO: Should we panic in this case? -- Someone obviously thinks there should be an SRT NoSRT -> return NoC_SRT + SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?" SRT off len bmp | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] -> do id <- newUnique