1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 1993-2004
5 -- The native code generator's monad.
7 -- -----------------------------------------------------------------------------
10 NatM_State(..), mkNatM_State,
12 NatM, -- instance Monad
13 initNat, addImportNat, getUniqueNat,
14 mapAccumLNat, setDeltaNat, getDeltaNat,
15 getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
18 #include "HsVersions.h"
20 import Cmm ( BlockId(..) )
21 import CLabel ( CLabel, mkAsmTempLabel )
23 import MachOp ( MachRep )
25 import Unique ( Unique )
28 data NatM_State = NatM_State {
29 natm_us :: UniqSupply,
31 natm_imports :: [(Bool,CLabel)]
34 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
38 mkNatM_State :: UniqSupply -> Int -> NatM_State
39 mkNatM_State us delta = NatM_State us delta []
41 initNat :: NatM_State -> NatM a -> (a, NatM_State)
42 initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
44 instance Monad NatM where
48 thenNat :: NatM a -> (a -> NatM b) -> NatM b
50 = NatM $ \st -> case unNat expr st of
51 (result, st') -> unNat (cont result) st'
53 returnNat :: a -> NatM a
54 returnNat result = NatM $ \st -> (result, st)
56 mapAccumLNat :: (acc -> x -> NatM (acc, y))
63 mapAccumLNat f b (x:xs)
64 = do (b__2, x__2) <- f b x
65 (b__3, xs__2) <- mapAccumLNat f b__2 xs
66 return (b__3, x__2:xs__2)
68 getUniqueNat :: NatM Unique
69 getUniqueNat = NatM $ \ (NatM_State us delta imports) ->
70 case splitUniqSupply us of
71 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
73 getDeltaNat :: NatM Int
74 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
76 setDeltaNat :: Int -> NatM ()
77 setDeltaNat delta = NatM $ \ (NatM_State us _ imports) ->
78 ((), NatM_State us delta imports)
80 addImportNat :: Bool -> CLabel -> NatM ()
81 addImportNat is_code imp = NatM $ \ (NatM_State us delta imports) ->
82 ((), NatM_State us delta ((is_code,imp):imports))
84 getBlockIdNat :: NatM BlockId
85 getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
87 getNewLabelNat :: NatM CLabel
88 getNewLabelNat = do u <- getUniqueNat; return (mkAsmTempLabel u)
90 getNewRegNat :: MachRep -> NatM Reg
91 getNewRegNat rep = do u <- getUniqueNat; return (mkVReg u rep)
93 getNewRegPairNat :: MachRep -> NatM (Reg,Reg)
94 getNewRegPairNat rep = do
96 let lo = mkVReg u rep; hi = getHiVRegFromLo lo