Harpy/X86CGCombinators.hs

   1 --------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  X86CodeGen
   4 -- Copyright   :  (c) 2006 Martin Grabmueller and Dirk Kleeblatt
   5 -- License     :  GPL
   6 --
   7 -- Maintainer  :  {magr,klee}@cs.tu-berlin.de
   8 -- Stability   :  quite experimental
   9 -- Portability :  portable (but generated code non-portable)
  10 --
  11 -- This module exports several combinators for writing loops,
  12 -- conditionals and function prolog\/epilog code.
  13 --
  14 -- Note: this module is under heavy development and the exported API
  15 -- is definitely not yet stable.
  16 --------------------------------------------------------------------------
  17
  18 module Harpy.X86CGCombinators(
  19   -- * Types
  20   UserState(..),
  21   UserEnv(..),
  22   emptyUserEnv,
  23   emptyUserState,
  24   CtrlDest(..),
  25   DataDest(..),
  26   -- * Combinators
  27   ifThenElse,
  28   doWhile,
  29   continue,
  30   continueBranch,
  31   saveRegs,
  32   function,
  33   withDataDest,
  34   withCtrlDest,
  35   withDest,
  36    ) where
  37
  38 import Text.PrettyPrint.HughesPJ
  39
  40 import Foreign
  41 import Data.Word
  42
  43 import Harpy.CodeGenMonad
  44 import Harpy.X86CodeGen
  45 import Harpy.X86Assembler
  46
  47 -- | Destination for a calculated value.
  48 data DataDest = RegDest Reg32            -- ^ Store into specific register
  49               | StackDest                -- ^ Push onto stack
  50               | MemBaseDest Reg32 Word32 -- ^ Store at memory address
  51               | Ignore                   -- ^ Throw result away.
  52
  53 -- | Destination for control transfers
  54 data CtrlDest = FallThrough              -- ^ Go to next instruction
  55               | Return                   -- ^ Return from current functio
  56               | Goto Label               -- ^ Go to specific label
  57               | Branch CtrlDest CtrlDest -- ^ Go to one of the given labels
  58                                          -- depending on outcome of test
  59
  60 -- | User state is used to maintain bitmask of registers currently in use.
  61 data UserState = UserState {}
  62
  63
  64 -- | User environment stores code generators for accessing specific
  65 -- variables as well as the current data and control destinations
  66 data UserEnv = UserEnv { bindings :: [(String, CodeGen UserEnv UserState ())],
  67                          dataDest :: DataDest,
  68                          ctrlDest :: CtrlDest }
  69
  70 emptyUserState :: UserState
  71 emptyUserState = UserState{}
  72
  73 emptyUserEnv :: UserEnv
  74 emptyUserEnv = UserEnv{bindings = [], dataDest = Ignore,
  75                        ctrlDest = Return}
  76
  77 ifThenElse :: CodeGen UserEnv s r
  78               -> CodeGen UserEnv s a
  79               -> CodeGen UserEnv s a1
  80               -> CodeGen UserEnv s ()
  81 ifThenElse condCg thenCg elseCg =
  82     do env <- getEnv
  83        elseLabel <- newLabel
  84        endLabel <- newLabel
  85        withDest Ignore (Branch FallThrough (Goto elseLabel)) condCg
  86        withCtrlDest (case ctrlDest env of
  87                        FallThrough -> Goto endLabel
  88                        _ -> ctrlDest env)
  89                     (thenCg >> continue)
  90        elseLabel @@ (elseCg >> continue)
  91        endLabel @@ return ()
  92
  93 doWhile :: CodeGen UserEnv s r -> CodeGen UserEnv s a -> CodeGen UserEnv s ()
  94 doWhile condCg bodyCg =
  95     do topLabel <- newLabel
  96        testLabel <- newLabel
  97        jmp testLabel
  98        topLabel @@ withCtrlDest FallThrough (bodyCg >> continue)
  99        testLabel @@ withDest Ignore (Branch (Goto topLabel) FallThrough)
 100                         condCg
 101        continue
 102
 103 doFor :: (Mov a Word32, Add a Word32, Cmp a Word32) => a -> Word32 -> Word32 -> Int32 ->
 104          CodeGen UserEnv s r ->
 105          CodeGen UserEnv s ()
 106 doFor loc from to step body =
 107     do topLabel <- newLabel
 108        testLabel <- newLabel
 109        mov loc from
 110        jmp testLabel
 111        topLabel @@ withCtrlDest FallThrough  (body >> continue)
 112        testLabel @@ cmp loc to
 113        add loc (fromIntegral step :: Word32)
 114        if step < 0
 115           then jge topLabel
 116           else jle topLabel
 117        continue
 118
 119
 120 continue :: CodeGen UserEnv s ()
 121 continue =
 122     do env <- getEnv
 123        cont (ctrlDest env)
 124   where
 125   cont FallThrough = return ()
 126   cont (Goto l) = jmp l
 127   cont (Branch _ _) = error "Branch in continue"
 128   cont Return = x86_epilog 0
 129
 130
 131 continueBranch :: Int -> Bool -> CodeGen UserEnv s ()
 132 continueBranch cc isSigned =
 133     do env <- getEnv
 134        let Branch c1 c2 = ctrlDest env
 135        cont cc isSigned c1 c2
 136   where
 137   cont cc isSigned (Goto l1) (Goto l2) =
 138     do x86_branch32 cc 0 isSigned
 139        emitFixup l1 (-4) Fixup32
 140        x86_branch32 (negateCC cc) 0 isSigned
 141        emitFixup l2 (-4) Fixup32
 142   cont cc isSigned (Goto l1) FallThrough =
 143     do x86_branch32 cc 0 isSigned
 144        emitFixup l1 (-4) Fixup32
 145   cont cc isSigned FallThrough (Goto l2) =
 146     do x86_branch32 (negateCC cc) 0 isSigned
 147        emitFixup l2 (-4) Fixup32
 148   cont cc isSigned (Goto l1) Return =
 149     do x86_branch32 cc 0 isSigned
 150        emitFixup l1 (-4) Fixup32
 151        withCtrlDest Return continue
 152   cont cc isSigned Return (Goto l2) =
 153     do x86_branch32 (negateCC cc) 0 isSigned
 154        emitFixup l2 (-4) Fixup32
 155        withCtrlDest Return continue
 156   cont _ _ _ _ = error "unhandled case in continueBranch"
 157
 158 reg sreg =
 159     do env <- getEnv
 160        reg' sreg (dataDest env)
 161   where
 162   reg' sreg (RegDest r) =
 163     do if sreg /= r
 164           then mov r sreg
 165           else return ()
 166   reg' sreg (StackDest) =
 167     do push sreg
 168   reg' sreg (MemBaseDest r offset) =
 169     do mov (Disp offset, r) sreg
 170   reg' sreg Ignore = return ()
 171
 172 membase reg ofs =
 173     do env <- getEnv
 174        membase' reg ofs (dataDest env)
 175   where
 176   membase' reg ofs (RegDest r) =
 177     do mov r (Disp ofs, reg)
 178   membase' reg ofs (StackDest) =
 179     do push (Disp ofs, reg)
 180   membase' reg ofs (MemBaseDest r offset) =
 181     do push edi
 182        mov edi (Disp ofs, reg)
 183        mov (Disp offset, r) edi
 184        pop edi
 185   membase' reg ofs Ignore = return ()
 186
 187 global ofs =
 188     do env <- getEnv
 189        global' ofs (dataDest env)
 190   where
 191   global' ofs (RegDest r) =
 192     do mov r (Addr ofs)
 193   global' ofs (StackDest) =
 194     do push (Addr ofs)
 195   global' ofs (MemBaseDest r offset) =
 196     do push edi
 197        mov edi (Addr ofs)
 198        mov (Disp offset, r) edi
 199        pop edi
 200   global' ofs Ignore = return ()
 201
 202 immediate value =
 203     do env <- getEnv
 204        immediate' value (dataDest env)
 205   where
 206   immediate' value (RegDest r) =
 207     do mov r value
 208   immediate' value (StackDest) =
 209     do x86_push_imm value
 210   immediate' value (MemBaseDest r offset) =
 211     do push edi
 212        mov edi value
 213        mov (Disp offset, r) edi
 214        pop edi
 215   immediate' ofs Ignore = return ()
 216
 217 -- | Save a number of registers on the stack, perform the given code
 218 -- generation, and restore the registers.
 219 saveRegs :: [Reg32] -> CodeGen UserEnv s r -> CodeGen UserEnv s ()
 220 saveRegs [] cg = cg >> return ()
 221 saveRegs regs cg =
 222     do gen_push regs
 223        withCtrlDest FallThrough cg
 224        gen_pop regs
 225        continue
 226   where
 227   gen_push [] = return ()
 228   gen_push (r:regs) = push r >> gen_push regs
 229   gen_pop [] = return ()
 230   gen_pop (r:regs) = gen_pop regs >> pop r
 231
 232 -- | Perform the code generation associated with the variable given.
 233 loadVar :: String -> CodeGen UserEnv UserState ()
 234 loadVar name =
 235     do UserEnv{bindings = assoc} <- getEnv
 236        case lookup name assoc of
 237          Just cg -> cg
 238          Nothing -> failCodeGen (text ("undefined variable: " ++ name))
 239
 240 -- | Set the data destinations to the given values while
 241 -- running the code generator.
 242 withDataDest :: DataDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r
 243 withDataDest ddest cg =
 244     do env <- getEnv
 245        withEnv (env{dataDest = ddest}) cg
 246
 247 -- | Set the control destinations to the given values while
 248 -- running the code generator.
 249 withCtrlDest :: CtrlDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r
 250 withCtrlDest cdest cg =
 251     do env <- getEnv
 252        withEnv (env{ctrlDest = cdest}) cg
 253
 254 -- | Set the data and control destinations to the given values while
 255 -- running the code generator.
 256 withDest :: DataDest -> CtrlDest -> CodeGen UserEnv s r -> CodeGen UserEnv s r
 257 withDest ddest cdest cg =
 258     do env <- getEnv
 259        withEnv (env{dataDest = ddest, ctrlDest = cdest}) cg
 260
 261 -- | Emit the necessary function prolog and epilog code and invoke the
 262 -- given code generator for the code inbetween.
 263 function :: CodeGen UserEnv s r -> CodeGen UserEnv s r
 264 function cg =
 265     do x86_prolog 0 0
 266        withDest (RegDest eax) Return $ cg