\section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code}
-#include "HsVersions.h"
-
module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
-- printing/forcing stuff comes from PprAbsC
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
+
+import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
+ -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
import AbsCSyn
-import CLabel ( mkReturnPtLabel )
-import Digraph ( stronglyConnComp )
+import Digraph ( stronglyConnComp, SCC(..) )
import HeapOffs ( possiblyEqualHeapOffset )
-import Id ( fIRST_TAG, ConTag(..) )
-import Literal ( literalPrimRep, Literal(..) )
+import Id ( fIRST_TAG, ConTag )
+import Literal ( literalPrimRep, Literal(..), mkMachWord )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
-import UniqSupply ( getUnique, getUniques, splitUniqSupply )
-import Util ( panic )
+import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
+import Util ( assocDefaultUsing, panic )
+import CmdLineOpts ( opt_ProduceC )
+import Maybes ( maybeToBool )
+import PrimOp ( PrimOp(..) )
infixr 9 `thenFlt`
\end{code}
-- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
- = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
- | (tag, abs_c) <- tagged_alts ]
+ = [ (mkMachWord (fromInt (tag - fIRST_TAG)), abs_c) | (tag, abs_c) <- tagged_alts ]
\end{code}
%************************************************************************
\begin{code}
magicIdPrimRep BaseReg = PtrRep
magicIdPrimRep StkOReg = PtrRep
-magicIdPrimRep (VanillaReg kind _) = kind
+magicIdPrimRep (VanillaReg kind _) = kind
magicIdPrimRep (FloatReg _) = FloatRep
magicIdPrimRep (DoubleReg _) = DoubleRep
+magicIdPrimRep (LongReg kind _) = kind
magicIdPrimRep TagReg = IntRep
magicIdPrimRep RetReg = RetRep
magicIdPrimRep SpA = PtrRep
do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
do_alt deflt_amode (Just alt) = flatAmode alt
- bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
+ bogus_default_label = panic ("flatAbsC: CRetVector: default needed and not available")
flatAbsC (CRetUnVector label amode)
= flatAmode cc `thenFlt` \ (new_cc, tops) ->
returnFlt (CInitHdr a b new_cc u, tops)
+flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
+ | maybeToBool opt_ProduceC
+ = flatAmodes results `thenFlt` \ (results_here, tops1) ->
+ flatAmodes args `thenFlt` \ (args_here, tops2) ->
+ let tdef = CCallTypedef td results args in
+ returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
+ mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
+
flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
= flatAmodes results `thenFlt` \ (results_here, tops1) ->
flatAmodes args `thenFlt` \ (args_here, tops2) ->
doSimultaneously1 :: [CVertex] -> FlatM AbstractC
doSimultaneously1 vertices
= let
- edges :: [CEdge]
- edges = concat (map edges_from vertices)
-
- edges_from :: CVertex -> [CEdge]
- edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
-
- should_follow :: CVertex -> CVertex -> Bool
- (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
- = dest1 `conflictsWith` src2
- (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
- = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
- (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
- = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
- (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
- = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-
--- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
--- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
-
- eq_vertex :: CVertex -> CVertex -> Bool
- (n1, _) `eq_vertex` (n2, _) = n1 == n2
-
- components = stronglyConnComp eq_vertex edges vertices
+ edges = [ (vertex, key1, edges_from stmt1)
+ | vertex@(key1, stmt1) <- vertices
+ ]
+ edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+ stmt1 `should_follow` stmt2
+ ]
+ components = stronglyConnComp edges
-- do_components deal with one strongly-connected component
- do_component :: [CVertex] -> FlatM AbstractC
+ -- Not cyclic, or singleton? Just do it
+ do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
+ do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
- -- A singleton? Then just do it.
- do_component [(n,abs_c)] = returnFlt abs_c
-
- -- Two or more? Then go via temporaries.
- do_component ((n,first_stmt):rest)
+ -- Cyclic? Then go via temporaries. Pick one to
+ -- break the loop and try again with the rest.
+ do_component (CyclicSCC ((n,first_stmt) : rest))
= doSimultaneously1 rest `thenFlt` \ abs_cs ->
go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
in
mapFlt do_component components `thenFlt` \ abs_cs ->
returnFlt (mkAbstractCs abs_cs)
+
+ where
+ should_follow :: AbstractC -> AbstractC -> Bool
+ (CAssign dest1 _) `should_follow` (CAssign _ src2)
+ = dest1 `conflictsWith` src2
+ (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
+ = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
+ (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
+ = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
+ (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
+ = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
+
+-- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
+-- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
+
+
\end{code}
projects / ghc-hetmet.git / blobdiff