-------------------------------------------------------------------------- -- | -- Module : X86CodeGen -- Copyright : (c) 2006 Martin Grabmueller and Dirk Kleeblatt -- License : GPL -- -- Maintainer : {magr,klee}@cs.tu-berlin.de -- Stability : quite experimental -- Portability : portable (but generated code non-portable) -- -- This module exports several combinators for writing loops, -- conditionals and function prolog\/epilog code. -- -- Note: this module is under heavy development and the exported API -- is definitely not yet stable. -------------------------------------------------------------------------- module Harpy.X86CGCombinators( -- * Types UserState(..), UserEnv(..), CtrlDest(..), DataDest(..), -- * Combinators ifThenElse, doWhile, continue, continueBranch, withDataDest, withCtrlDest, withDest, function, withRegister ) where import Text.PrettyPrint.HughesPJ import Foreign import Harpy.CodeGenMonad import Harpy.X86CodeGen -- | Destination for a calculated value. data DataDest = RegDest Word8 -- ^ Store into specific register | StackDest -- ^ Push onto stack | MemBaseDest Word8 Word32 -- ^ Store at memory address | Ignore -- ^ Throw result away. -- | Destination for control transfers data CtrlDest = FallThrough -- ^ Go to next instruction | Return -- ^ Return from current functio | Goto Label -- ^ Go to specific label | Branch CtrlDest CtrlDest -- ^ Go to one of the given labels -- depending on outcome of test -- | User state is used to maintain bitmask of registers currently in use. data UserState = UserState { usedRegs :: Int} -- | User environment stores code generators for accessing specific -- variables as well as the current data and control destinations data UserEnv = UserEnv { bindings :: [(String, CodeGen UserEnv UserState ())], dataDest :: DataDest, ctrlDest :: CtrlDest } emptyUserState = UserState{usedRegs = 0} emptyUserEnv = UserEnv{bindings = [], dataDest = Ignore, ctrlDest = Return} ifThenElse :: CodeGen UserEnv s r -> CodeGen UserEnv s a -> CodeGen UserEnv s a1 -> CodeGen UserEnv s () ifThenElse condCg thenCg elseCg = do env <- getEnv elseLabel <- newLabel endLabel <- newLabel withDest Ignore (Branch FallThrough (Goto elseLabel)) (condCg) withCtrlDest (case ctrlDest env of FallThrough -> Goto endLabel _ -> ctrlDest env) (thenCg >> continue) defineLabel elseLabel elseCg >> continue defineLabel endLabel doWhile :: CodeGen UserEnv s r -> CodeGen UserEnv s a -> CodeGen UserEnv s () doWhile condCg bodyCg = do topLabel <- newLabel testLabel <- newLabel emitFixup testLabel 1 Fixup8 x86_jump8 0 defineLabel topLabel withCtrlDest FallThrough (bodyCg >> continue) defineLabel testLabel withDest Ignore (Branch (Goto topLabel) FallThrough) condCg continue continue :: CodeGen UserEnv s () continue = do env <- getEnv cont (ctrlDest env) where cont FallThrough = return () cont (Goto l) = emitFixup l 1 Fixup32 >> x86_jump32 0 cont (Branch _ _) = error "Branch in continue" cont Return = x86_epilog 0 continueBranch :: Int -> Bool -> CodeGen UserEnv s () continueBranch cc isSigned = do env <- getEnv let Branch c1 c2 = ctrlDest env cont cc isSigned c1 c2 where cont cc isSigned (Goto l1) (Goto l2) = do emitFixup l1 1 Fixup32 x86_branch32 cc 0 isSigned emitFixup l2 1 Fixup32 x86_branch32 (negateCC cc) 0 isSigned cont cc isSigned (Goto l1) FallThrough = do emitFixup l1 1 Fixup32 x86_branch32 cc 0 isSigned cont cc isSigned FallThrough (Goto l2) = do emitFixup l2 1 Fixup32 x86_branch32 (negateCC cc) 0 isSigned cont cc isSigned (Goto l1) Return = do emitFixup l1 1 Fixup32 x86_branch32 cc 0 isSigned withCtrlDest Return continue cont cc isSigned Return (Goto l2) = do emitFixup l2 1 Fixup32 x86_branch32 (negateCC cc) 0 isSigned withCtrlDest Return continue cont _ _ _ _ = error "unhandled case in continueBranch" reg sreg = do env <- getEnv reg' sreg (dataDest env) where reg' sreg (RegDest r) = do if sreg /= r then x86_mov_reg_reg r sreg x86_dword_size else return () reg' sreg (StackDest) = do x86_push_reg sreg reg' sreg (MemBaseDest r offset) = do x86_mov_membase_reg r offset sreg x86_dword_size reg' sreg Ignore = return () membase reg ofs = do env <- getEnv membase' reg ofs (dataDest env) where membase' reg ofs (RegDest r) = do x86_mov_reg_membase r reg ofs x86_dword_size membase' reg ofs (StackDest) = do x86_push_membase reg ofs membase' reg ofs (MemBaseDest r offset) = do x86_mov_reg_membase x86_edi reg ofs x86_dword_size x86_mov_membase_reg r offset x86_edi x86_dword_size membase' reg ofs Ignore = return () global ofs = do env <- getEnv global' ofs (dataDest env) where global' ofs (RegDest r) = do x86_mov_reg_mem r ofs x86_dword_size global' ofs (StackDest) = do x86_push_mem ofs global' ofs (MemBaseDest r offset) = do x86_mov_reg_mem x86_edi ofs x86_dword_size x86_mov_membase_reg r offset x86_edi x86_dword_size global' ofs Ignore = return () immediate value = do env <- getEnv immediate' value (dataDest env) where immediate' value (RegDest r) = do x86_mov_reg_imm r value immediate' value (StackDest) = do x86_push_imm value immediate' value (MemBaseDest r offset) = do x86_mov_reg_imm x86_edi value x86_mov_membase_reg r offset x86_edi x86_dword_size immediate' ofs Ignore = return () -- | Save a number of registers on the stack, perform the given code -- generation, and restore the registers. saveRegs :: (Bits a) => a -> CodeGen UserEnv s r -> CodeGen UserEnv s () saveRegs reg_mask cg = do gen_push 0 1 withCtrlDest FallThrough cg gen_pop x86_edi (1 `shiftL` (fromIntegral x86_edi)) continue where gen_push i m = if i <= x86_edi then do if (reg_mask .&. m) /= 0 then x86_push_reg i else return () gen_push (i + 1) (m `shiftL` 1) else return () gen_pop i m = if m /= 0 then do if (reg_mask .&. m) /= 0 then x86_pop_reg i else return () gen_pop (i - 1) (m `shiftR` 1) else return () -- | Perform the code generation associated with the variable given. loadVar :: String -> CodeGen UserEnv UserState () loadVar name = do UserEnv{bindings = assoc} <- getEnv case lookup name assoc of Just cg -> cg Nothing -> failCodeGen (text ("undefined variable: " ++ name)) -- | Find a register not recorded in the given bit mask. findReg :: (Bits a) => a -> Word8 findReg reg_mask = findR 0 1 where findR i m = if i <= x86_edi then if (reg_mask .&. m) == 0 then i else findR (i + 1) (m `shiftL` 1) else error "no register left for allocation" -- | Set the data destinations to the given values while -- running the code generator. withDataDest :: DataDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r withDataDest ddest cg = do env <- getEnv withEnv (env{dataDest = ddest}) cg -- | Set the control destinations to the given values while -- running the code generator. withCtrlDest :: CtrlDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r withCtrlDest cdest cg = do env <- getEnv withEnv (env{ctrlDest = cdest}) cg -- | Set the data and control destinations to the given values while -- running the code generator. withDest :: DataDest -> CtrlDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r withDest ddest cdest cg = do env <- getEnv withEnv (env{dataDest = ddest, ctrlDest = cdest}) cg -- | Emit the necessary function prolog and epilog code and invoke the -- given code generator for the code inbetween. function :: CodeGen UserEnv s r -> CodeGen UserEnv s r function cg = do x86_prolog 0 0 withDataDest (RegDest x86_eax) $ withCtrlDest Return $ cg -- | Apply the given cg to a register, which is reserved while the -- generator is running. withRegister :: (Word8 -> CodeGen e UserState t) -> CodeGen e UserState () withRegister cg = do state <- getState let used = usedRegs state let reg = findReg used setState (state{usedRegs = used .|. (1 `shiftL` fromIntegral reg)}) cg reg state <- getState setState (state{usedRegs = used})