X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCvt.hs;h=0f0ccd2d1b77d824f13c3a176525975a9fdfca60;hp=0bfa396b9b3e0eaecba0b29fb101b9c47df4b77a;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=e06951a75a1f519e8f015880c363a8dedc08ff9c diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 0bfa396..0f0ccd2 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -5,14 +5,14 @@ module CmmCvt where import BlockId +import ClosureInfo (C_SRT(..)) import Cmm import CmmExpr -import MkZipCfg import MkZipCfgCmm hiding (CmmGraph) import ZipCfgCmmRep -- imported for reverse conversion import CmmZipUtil +import ForeignCall import PprCmm() -import PprCmmZ() import qualified ZipCfg as G import FastString @@ -31,25 +31,26 @@ cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops where mapTop (CmmProc h l args g) = toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args mapTop (CmmData s ds) = return $ CmmData s ds -cmmOfZgraph = cmmMapGraph ofZgraph +cmmOfZgraph = cmmMapGraph ofZgraph - -toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph -toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph +toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph +toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = - labelAGraph id $ mkMiddles (mkEntry area undefined args) <*> - mkStmts ss <*> foldr addBlock emptyAGraph other_blocks - where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g + let (offset, entry) = mkEntry id Native args in + labelAGraph id offset $ + entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks + where addBlock (BasicBlock id ss) g = mkLabel id Nothing <*> mkStmts ss <*> g mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) = - mkCall f conv res args srt <*> mkStmts ss + mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> mkStmts ss mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) = panic "safe call to a primitive CmmPrim CallishMachOp" mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) = - mkUnsafeCall f res args <*> mkStmts ss + mkUnsafeCall (convert_target f res args) + (strip_hints res) (strip_hints args) <*> mkStmts ss mkStmts (CmmCondBranch e l : fbranch) = mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch) mkStmts (last : []) = mkLast last @@ -57,32 +58,41 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = mkStmts (_ : _ : _) = bad "last node not at end" bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g) mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) = - mkFinalCall f conv args + mkFinalCall f conv $ map hintlessCmm args mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) = panic "Call to CmmPrim never returns?!" mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table - mkLast (CmmJump tgt args) = mkJump area tgt args - mkLast (CmmReturn ress) = mkReturn area ress + -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING + -- CONVENTIONS ARE HONORED? + mkLast (CmmJump tgt args) = mkJump tgt $ map hintlessCmm args + mkLast (CmmReturn ress) = mkReturn $ map hintlessCmm ress mkLast (CmmBranch tgt) = mkBranch tgt mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) = panic "Call never returns but has results?!" mkLast _ = panic "fell off end of block" - -- The entry, jump, and return areas should be the same. - -- This code is horrible, but there's no point trying to fix it until we've figured - -- out our interface for calling conventions. - -- All return statements are required to use return areas of equal size. - -- This isn't necessarily required to write correct programs, but it's sane. - area = case foldr retBlock (retStmts ss Nothing) other_blocks of - Just (as, _) -> mkCallArea id as $ Just args - Nothing -> mkCallArea id [] $ Just args - retBlock (BasicBlock _ ss) z = retStmts ss z - retStmts [CmmReturn ress] z@(Just (_, n)) = - if size ress == n then z - else panic "return statements in C-- procs must return the same results" - retStmts [CmmReturn ress] Nothing = Just (ress, size ress) - retStmts (_ : rst) z = retStmts rst z - retStmts [] z = z - size args = areaSize $ mkCallArea id args Nothing + +strip_hints :: [CmmHinted a] -> [a] +strip_hints = map hintlessCmm + +convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget +convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress)) +convert_target (CmmPrim op) _ress _args = PrimTarget op + +add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a] +add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd) + +get_hints :: Convention -> ValueDirection -> [ForeignHint] +get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints +get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints +get_hints _other_conv _vd = repeat NoHint + +get_conv :: MidCallTarget -> Convention +get_conv (PrimTarget _) = Native +get_conv (ForeignTarget _ fc) = Foreign fc + +cmm_target :: MidCallTarget -> CmmCallTarget +cmm_target (PrimTarget op) = CmmPrim op +cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc ofZgraph :: CmmGraph -> ListGraph CmmStmt ofZgraph g = ListGraph $ swallow blocks @@ -92,89 +102,67 @@ ofZgraph g = ListGraph $ swallow blocks extend_block _id stmts = stmts _extend_entry stmts = scomment showblocks : scomment cscomm : stmts showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++ - concat (map (\(G.Block id _) -> " " ++ show id) blocks) + concat (map (\(G.Block id _ _) -> " " ++ show id) blocks) cscomm = "Call successors are" ++ (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs) swallow [] = [] - swallow (G.Block id t : rest) = tail id [] Nothing t rest - tail id prev' out (G.ZTail (CopyOut conv actuals) t) rest = - case out of - Nothing -> tail id prev' (Just (conv, actuals)) t rest - Just _ -> panic "multiple CopyOut nodes in one basic block" - tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest - tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest - tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out l rest + swallow (G.Block id _ t : rest) = tail id [] t rest + tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest + tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest + tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest mid (MidComment s) = CmmComment s mid (MidAssign l r) = CmmAssign l r mid (MidStore l r) = CmmStore l r - mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn + mid (MidUnsafeCall target ress args) + = CmmCall (cmm_target target) + (add_hints conv Results ress) + (add_hints conv Arguments args) + CmmUnsafe CmmMayReturn + where + conv = get_conv target mid m@(MidAddToContext {}) = pcomment (ppr m) - mid m@(CopyOut {}) = pcomment (ppr m) - mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)") pcomment p = scomment $ showSDoc p block' id prev' | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev') | otherwise = BasicBlock id $ extend_block id (reverse prev') - last id prev' out l n = + last id prev' l n = let endblock stmt = block' id (stmt : prev') : swallow n in case l of LastBranch tgt -> case n of - G.Block id' t : bs - | tgt == id', unique_pred id' - -> tail id prev' out t bs -- optimize out redundant labels - _ -> if isNothing out then endblock (CmmBranch tgt) - else pprPanic "can't convert LGraph with pending CopyOut" - (text "target" <+> ppr tgt <+> ppr g) + -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH + --G.Block id' _ t : bs + -- | tgt == id', unique_pred id' + -- -> tail id prev' t bs -- optimize out redundant labels + _ -> endblock (CmmBranch tgt) LastCondBranch expr tid fid -> - if isJust out then pprPanic "CopyOut before conditional branch" (ppr g) - else case n of - G.Block id' t : bs + G.Block id' _ t : bs | id' == fid, unique_pred id' -> - tail id (CmmCondBranch expr tid : prev') Nothing t bs + tail id (CmmCondBranch expr tid : prev') t bs | id' == tid, unique_pred id', Just e' <- maybeInvertCmmExpr expr -> - tail id (CmmCondBranch e' fid : prev') Nothing t bs + tail id (CmmCondBranch e' fid : prev') t bs _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n - LastJump expr -> endblock $ with_out out $ CmmJump expr - LastReturn -> endblock $ with_out out $ CmmReturn + LastJump expr _ -> endblock $ CmmJump expr [] + LastReturn _ -> endblock $ CmmReturn [] LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids - LastCall e cont - | Just (conv, args) <- out - -> let tgt = CmmCallee e (conv_to_cconv conv) in - case cont of - Nothing -> - endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns - Just k - | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n, - id' == k, unique_pred k - -> let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn - in tail id (call : prev') Nothing t bs - | G.Block id' t : bs <- n, id' == k, unique_pred k - -> let (ress, srt) = findCopyIn t - call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn - delayed = scomment "delayed CopyIn follows prev. call" - in tail id (delayed : call : prev') Nothing t bs - | otherwise -> panic "unrepairable call" - | otherwise -> panic "call with no CopyOut" - with_out (Just (_conv, actuals)) f = f actuals - with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f []) - findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt) - findCopyIn (G.ZTail _ t) = findCopyIn t - findCopyIn (G.ZLast _) = panic "missing CopyIn after call" - exit id prev' out n = -- highly irregular (assertion violation?) + LastCall e cont _ -> + let tgt = CmmCallee e CCallConv in + case cont of + Nothing -> + endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns + Just _ -> + endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn + exit id prev' n = -- highly irregular (assertion violation?) let endblock stmt = block' id (stmt : prev') : swallow n in case n of [] -> endblock (scomment "procedure falls off end") - G.Block id' t : bs -> + G.Block id' _ t : bs -> if unique_pred id' then - tail id (scomment "went thru exit" : prev') out t bs + tail id (scomment "went thru exit" : prev') t bs else endblock (CmmBranch id') - conv_to_cconv (ConventionStandard c _) = c - conv_to_cconv (ConventionPrivate {}) = - panic "tried to convert private calling convention back to Cmm" preds = zipPreds g single_preds = let add b single = @@ -189,7 +177,7 @@ ofZgraph g = ListGraph $ swallow blocks call_succs = let add b succs = case G.last (G.unzip b) of - G.LastOther (LastCall _ (Just id)) -> extendBlockSet succs id + G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id _ -> succs in G.fold_blocks add emptyBlockSet g _is_call_succ id = elemBlockSet id call_succs