harpy-0.2: Harpy/X86CGCombinators.hs
--------------------------------------------------------------------------
-- |
-- 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})