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
  95 instance Function () Compiler where
  96     fun def = Main $
  97         freshLabel >>= \funlabel->
  98         let g :- m = def (\()->instr [Jsr funlabel])
  99         in  liftFunction funlabel 0 (g ()) >> unmain m
 100
 101 instance Function (Compiler a) Compiler where
 102     fun def = Main $
 103         freshLabel >>= \funlabel->
 104         let g :- m = def (\a->a >> instr [Jsr funlabel])
 105         in  liftFunction funlabel 1 (g (instr [Arg 0])) >> unmain m
 106
 107 instance Function (Compiler a, Compiler b) Compiler where
 108     fun def = Main $
 109         freshLabel >>= \funlabel->
 110         let g :- m = def (\(a, b)->a >> b >> instr [Jsr funlabel])
 111         in  liftFunction funlabel 2 (g (instr [Arg 1], instr [Arg 0])) >> unmain m
 112
 113 instance Function (Compiler a, Compiler b, Compiler c) Compiler where
 114     fun def = Main $
 115         freshLabel >>= \funlabel->
 116         let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel])
 117         in  liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
 118
 119 liftFunction :: Int -> Int -> Compiler a -> Compiler ()
 120 liftFunction lbl nargs body = do
 121     is <- snd <$> censor (\_->[]) (listen body)
 122     let instructions = Lbl lbl : is ++ [Ret nargs]
 123     modify (\s->s { functions=DM.insert lbl instructions $ functions s })
 124
 125 data Instr
 126     = Push Int | Pop Int | Dup | Roll Int Int
 127     | Add | Sub | Mul | Div | Neg | Pow
 128     | And | Or | Not
 129     | Eq | Neq | Le | Ge | Leq | Geq
 130     | Lbl Int | Bra Int | Brf Int
 131     | Str Int | Ldr Int
 132     | Sth Int | Ldh Int
 133     | Jsr Int | Ret Int | Arg Int
 134     | Halt
 135   deriving Show
 136
 137 data Registers = Registers
 138     { pc :: Int
 139     , hp :: Int
 140     , sp :: Int
 141     , mp :: Int
 142     , gp :: DM.Map Int Int
 143     }
 144   deriving Show
 145
 146 interpret :: Int -> [Instr] -> Array Int Int
 147 interpret memsize prog = runSTArray $ do
 148     program <- newListArray (0, length prog) prog
 149     mem <- newArray (0, memsize-1) 0
 150     int program mem (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
 151   where
 152     pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 153     pushh memory value reg = do
 154         writeArray memory (hp reg) value
 155         pure (reg { hp = hp reg + 1} )
 156
 157     loadh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 158     loadh memory hptr registers = readArray memory hptr >>= flip (push memory) registers
 159
 160     push :: STArray s Int Int -> Int -> Registers -> ST s Registers
 161     push memory value reg = do
 162         writeArray memory (sp reg) value
 163         pure (reg { sp = sp reg - 1} )
 164
 165     pop :: STArray s Int Int -> Registers -> ST s (Registers, Int)
 166     pop memory reg = do
 167         v <- readArray memory (sp reg + 1)
 168         pure (reg { sp = sp reg + 1}, v)
 169
 170     popn :: STArray s Int Int -> Int -> Registers -> ST s (Registers, [Int])
 171     popn _ 0 reg = pure (reg, [])
 172     popn memory n reg = do
 173         (reg', v) <- pop memory reg
 174         (reg'', vs) <- popn memory (n - 1) reg'
 175         pure (reg'', v:vs)
 176
 177     bop :: (Int -> Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 178     bop op memory reg = do
 179         (reg1, r) <- pop memory reg
 180         uop (flip op r) memory reg1
 181
 182     uop :: (Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 183     uop op memory reg = do
 184         (reg1, r) <- pop memory reg
 185         push memory (op r) reg1
 186
 187     int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
 188     int program memory registers = do
 189         instruction <- readArray program $ pc registers
 190         stack <- getElems memory
 191         let reg = registers { pc = pc registers + 1 }
 192         case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of
 193 --        case instruction of
 194             Str r -> do
 195                 (reg', v) <- pop memory reg
 196                 int program memory $ reg' { gp = DM.insert r v (gp reg')}
 197             Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
 198             Roll 0 _ -> int program memory reg
 199             Roll 1 _ -> int program memory reg
 200             Roll _ 0 -> int program memory reg
 201             Roll depth num -> do
 202                 (reg', vs) <- popn memory depth reg
 203                 foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory
 204               where
 205                 roll 0 acc vs = vs ++ reverse acc
 206                 roll n acc [] = roll n [] $ reverse acc
 207                 roll n acc (v:vs) = roll (n-1) (v:acc) vs
 208             Pop n -> popn memory n reg >>= int program memory . fst
 209             Push v -> push memory v reg >>= int program memory
 210             Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory
 211             Add -> bop (+) memory reg >>= int program memory
 212             Sub -> bop (-) memory reg >>= int program memory
 213             Mul -> bop (*) memory reg >>= int program memory
 214             Div -> bop div memory reg >>= int program memory
 215             Neg -> uop negate memory reg >>= int program memory
 216             Pow -> bop (^) memory reg >>= int program memory
 217             And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory
 218             Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
 219             Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory
 220             Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory
 221             Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory
 222             Le -> bop ((b2i .) . (<)) memory reg >>= int program memory
 223             Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory
 224             Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory
 225             Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory
 226             Lbl _ -> int program memory reg
 227             Bra l -> branch l program reg >>= int program memory
 228             Brf l -> do
 229                 (reg', v) <- pop memory reg
 230                 reg'' <- if i2b v then pure reg' else branch l program reg'
 231                 int program memory reg''
 232             Sth n ->
 233                     popn memory n reg
 234                 >>= uncurry (foldM $ flip $ pushh memory)
 235                 >>= push memory (hp reg + n - 1)
 236                 >>= int program memory
 237             Ldh n -> pop memory reg >>= \(reg', hptr)->loadh memory (hptr - n - 1) reg'
 238                 >>= int program memory
 239             Jsr i -> push memory (pc reg) reg
 240                 >>= push memory (mp reg)
 241                 >>= branch i program
 242                 >>= \r->int program memory (r { mp = sp r})
 243             Ret n -> do
 244                 (reg1, rval) <- pop memory reg
 245                 (reg2, omp) <- pop memory reg1
 246                 (reg3, ra) <- pop memory reg2
 247                 (reg4, _) <- popn memory n reg3
 248                 reg5 <- push memory rval reg4
 249                 int program memory $ reg5 { pc=ra, mp=omp }
 250             Arg n -> do
 251                 v <- readArray memory (mp reg + 3 + n)
 252                 push memory v reg >>= int program memory
 253             Halt -> pure memory
 254
 255     branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers
 256     branch label program reg = case pc reg of
 257         -1 -> getBounds program >>= \(_, m)->branch label program $ reg { pc = m - 1}
 258         _ -> readArray program (pc reg) >>= \case
 259             Lbl l | label == l -> pure $ reg
 260             _ -> branch label program $ reg { pc = pc reg - 1 }
 261
 262 b2i :: Bool -> Int
 263 b2i True = 1
 264 b2i False = 0
 265
 266 i2b :: Int -> Bool
 267 i2b 0 = False
 268 i2b _ = True