datatype/Compiler.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE LambdaCase #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 module Compiler where
   7
   8 import Language
   9 import Serialise
  10
  11 import qualified Data.Map as DM
  12 import Control.Monad.Writer
  13 import Control.Monad.State
  14 import Control.Monad.ST
  15 import Debug.Trace
  16 import Data.Array
  17 import Data.Array.ST
  18 import Data.Function
  19
  20 newtype Compiler a = Compiler { unCompiler :: StateT CS (WriterT [Instr] (Either String)) a }
  21   deriving
  22         ( Functor
  23         , Applicative
  24         , Monad
  25         , MonadWriter [Instr]
  26         , MonadState CS
  27         )
  28 instance MonadFail Compiler where fail s = Compiler $ lift $ lift $ Left s
  29 data CS = CS
  30     { fresh :: [Int]
  31     , functions :: DM.Map Int [Instr]
  32     }
  33
  34 runCompiler :: Compiler a -> Either String [Instr]
  35 runCompiler c = execWriterT
  36     $ evalStateT (unCompiler (c >> instr [Halt] >> writeFunctions))
  37     $ CS {fresh=[0..], functions=DM.empty}
  38   where
  39     writeFunctions :: Compiler ()
  40     writeFunctions = gets (DM.elems . functions) >>= tell . concat
  41
  42 instr :: [Instr] -> Compiler a
  43 instr i = tell i >> pure undefined
  44
  45 freshLabel :: Compiler Int
  46 freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs)
  47
  48 binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b
  49 binop i l r = l >> r >> instr [i]
  50
  51 unop :: Instr -> Compiler a -> Compiler b
  52 unop i l = l >> instr [i]
  53
  54 instance Expression Compiler where
  55     lit v = instr $ map Push $ serialise v []
  56     (+.) = binop Add
  57     (-.) = binop Sub
  58     (/.) = binop Div
  59     (*.) = binop Mul
  60     (^.) = binop Pow
  61 --    (^.) l r = freshLabel >>= \lblstart->freshLabel >>= \lblend->
  62 --        l >> r >> instr -- pow (x, y) {
  63 --            [ Str 1
  64 --            , Str 0
  65 --            , Push 1        -- res = 1
  66 --            , Lbl lblstart  -- while
  67 --            , Ldr 1         -- (y == 0)
  68 --            , Push 0        --
  69 --            , Neq           --
  70 --            , Brf lblend    --
  71 --            , Ldr 0         -- res *= x
  72 --            , Mul           --
  73 --            , Ldr 1         -- y -= 1
  74 --            , Push 1        --
  75 --            , Sub           --
  76 --            , Str 1         --
  77 --            , Bra lblstart  --
  78 --            , Lbl lblend    --
  79 --            ]
  80     neg = unop Neg
  81     (&.) = binop And
  82     (|.) = binop Or
  83     not = unop Not
  84     (==.) = binop Eq
  85     (/=.) = binop Neq
  86     (<.) = binop Le
  87     (>.) = binop Ge
  88     (<=.) = binop Leq
  89     (>=.) = binop Geq
  90     if' p t e = freshLabel >>= \elselabel-> freshLabel >>= \endiflabel->
  91         p >> instr [Brf elselabel] >>
  92         t >> instr [Bra endiflabel, Lbl elselabel] >>
  93         e >> instr [Lbl endiflabel]
  94     bottom msg = instr [Error msg]
  95
  96 instance Function () Compiler where
  97     fun def = Main $
  98         freshLabel >>= \funlabel->
  99         let g :- m = def (\()->instr [Jsr funlabel])
 100         in  liftFunction funlabel 0 (g ()) >> unmain m
 101
 102 instance Function (Compiler a) Compiler where
 103     fun def = Main $
 104         freshLabel >>= \funlabel->
 105         let g :- m = def (\a->a >> instr [Jsr funlabel])
 106         in  liftFunction funlabel 1 (g (instr [Arg 0])) >> unmain m
 107
 108 instance Function (Compiler a, Compiler b) Compiler where
 109     fun def = Main $
 110         freshLabel >>= \funlabel->
 111         let g :- m = def (\(a, b)->a >> b >> instr [Jsr funlabel])
 112         in  liftFunction funlabel 2 (g (instr [Arg 1], instr [Arg 0])) >> unmain m
 113
 114 instance Function (Compiler a, Compiler b, Compiler c) Compiler where
 115     fun def = Main $
 116         freshLabel >>= \funlabel->
 117         let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel])
 118         in  liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
 119
 120 liftFunction :: Int -> Int -> Compiler a -> Compiler ()
 121 liftFunction lbl nargs body = do
 122     is <- snd <$> censor (\_->[]) (listen body)
 123     let instructions = Lbl lbl : is ++ [Ret nargs]
 124     modify (\s->s { functions=DM.insert lbl instructions $ functions s })
 125
 126 data Instr
 127     = Push Int | Pop Int -- | Dup | Roll Int Int
 128     | Add | Sub | Mul | Div | Neg | Pow
 129     | And | Or | Not
 130     | Eq | Neq | Le | Ge | Leq | Geq
 131     | Lbl Int | Bra Int | Brf Int
 132     | Str Int | Ldr Int
 133     | Sth Int | Ldh Int
 134     | Jsr Int | Ret Int | Arg Int
 135     | Halt | Error String
 136   deriving Show
 137
 138 data Registers = Registers
 139     { pc :: Int
 140     , hp :: Int
 141     , sp :: Int
 142     , mp :: Int
 143     , gp :: DM.Map Int Int
 144     }
 145   deriving Show
 146
 147 interpret :: Int -> [Instr] -> Int
 148 interpret memsize prog = runSTArray resultStack ! (memsize-1)
 149   where
 150     resultStack :: ST s (STArray s Int Int)
 151     resultStack = join $ int
 152         <$> newListArray (0, length prog) prog
 153         <*> newArray (0, memsize-1) 0
 154         <*> pure (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
 155
 156     pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 157     pushh memory value reg = do
 158         writeArray memory (hp reg) value
 159         pure (reg { hp = hp reg + 1} )
 160
 161     loadh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 162     loadh memory hptr registers = readArray memory hptr >>= flip (push memory) registers
 163
 164     push :: STArray s Int Int -> Int -> Registers -> ST s Registers
 165     push memory value reg = do
 166         writeArray memory (sp reg) value
 167         pure (reg { sp = sp reg - 1} )
 168
 169     pop :: STArray s Int Int -> Registers -> ST s (Registers, Int)
 170     pop memory reg = do
 171         v <- readArray memory (sp reg + 1)
 172         pure (reg { sp = sp reg + 1}, v)
 173
 174     popn :: STArray s Int Int -> Int -> Registers -> ST s (Registers, [Int])
 175     popn _ 0 reg = pure (reg, [])
 176     popn memory n reg = do
 177         (reg', v) <- pop memory reg
 178         (reg'', vs) <- popn memory (n - 1) reg'
 179         pure (reg'', v:vs)
 180
 181     bop :: (Int -> Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 182     bop op memory reg = do
 183         (reg1, r) <- pop memory reg
 184         uop (flip op r) memory reg1
 185
 186     uop :: (Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 187     uop op memory reg = do
 188         (reg1, r) <- pop memory reg
 189         push memory (op r) reg1
 190
 191     int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
 192     int program memory registers = do
 193         instruction <- readArray program $ pc registers
 194         stack <- getElems memory
 195         let reg = registers { pc = pc registers + 1 }
 196         case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of
 197 --        case instruction of
 198             Str r -> do
 199                 (reg', v) <- pop memory reg
 200                 int program memory $ reg' { gp = DM.insert r v (gp reg')}
 201             Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
 202 --            Roll 0 _ -> int program memory reg
 203 --            Roll 1 _ -> int program memory reg
 204 --            Roll _ 0 -> int program memory reg
 205 --            Roll depth num -> do
 206 --                (reg', vs) <- popn memory depth reg
 207 --                foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory
 208 --              where
 209 --                roll 0 acc vs = vs ++ reverse acc
 210 --                roll n acc [] = roll n [] $ reverse acc
 211 --                roll n acc (v:vs) = roll (n-1) (v:acc) vs
 212             Pop n -> popn memory n reg >>= int program memory . fst
 213             Push v -> push memory v reg >>= int program memory
 214 --            Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory
 215             Add -> bop (+) memory reg >>= int program memory
 216             Sub -> bop (-) memory reg >>= int program memory
 217             Mul -> bop (*) memory reg >>= int program memory
 218             Div -> bop div memory reg >>= int program memory
 219             Neg -> uop negate memory reg >>= int program memory
 220             Pow -> bop (^) memory reg >>= int program memory
 221             And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory
 222             Or  -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
 223             Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory
 224             Eq  -> bop ((b2i .) . (==)) memory reg >>= int program memory
 225             Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory
 226             Le  -> bop ((b2i .) . (<)) memory reg >>= int program memory
 227             Ge  -> bop ((b2i .) . (>)) memory reg >>= int program memory
 228             Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory
 229             Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory
 230             Lbl _ -> int program memory reg
 231             Bra l -> branch l program reg >>= int program memory
 232             Brf l -> do
 233                 (reg', v) <- pop memory reg
 234                 reg'' <- if i2b v then pure reg' else branch l program reg'
 235                 int program memory reg''
 236             Sth n ->
 237                     popn memory n reg
 238                 >>= uncurry (foldM $ flip $ pushh memory)
 239                 >>= push memory (hp reg + n - 1)
 240                 >>= int program memory
 241             Ldh n -> pop memory reg >>= \(reg', hptr)->loadh memory (hptr - n - 1) reg'
 242                 >>= int program memory
 243             Jsr i -> push memory (pc reg) reg
 244                 >>= push memory (mp reg)
 245                 >>= branch i program
 246                 >>= \r->int program memory (r { mp = sp r})
 247             Ret n -> do
 248                 (reg1, rval:omp:ra:_) <- popn memory (3+n) reg
 249                 reg2 <- push memory rval reg1
 250                 int program memory $ reg2 { pc=ra, mp=omp }
 251             Arg n -> do
 252                 v <- readArray memory (mp reg + 3 + n)
 253                 push memory v reg >>= int program memory
 254             Halt -> pure memory
 255             Error msg -> fail msg
 256
 257     branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers
 258     branch label program reg = case pc reg of
 259         -1 -> getBounds program >>= \(_, m)->branch label program $ reg { pc = m - 1}
 260         _ -> readArray program (pc reg) >>= \case
 261             Lbl l | label == l -> pure $ reg
 262             _ -> branch label program $ reg { pc = pc reg - 1 }
 263
 264 b2i :: Bool -> Int
 265 b2i True = 1
 266 b2i False = 0
 267
 268 i2b :: Int -> Bool
 269 i2b 0 = False
 270 i2b _ = True