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 = gets fresh >>= \(f:fs)->modify (\s->s { fresh=fs }) >> pure f
  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 DSL Compiler
  55 instance Expression Compiler where
  56     lit v = instr [Push $ serialise v]
  57     (+.) = binop Add
  58     (-.) = binop Sub
  59     (/.) = binop Div
  60     (*.) = binop Mul
  61     neg = unop Neg
  62     (&.) = binop And
  63     (|.) = binop Or
  64     not = unop Not
  65     (==.) = binop Eq
  66     (/=.) = binop Neq
  67     (<.) = binop Le
  68     (>.) = binop Ge
  69     (<=.) = binop Leq
  70     (>=.) = binop Geq
  71     if' p t e = freshLabel >>= \elselabel-> freshLabel >>= \endiflabel->
  72         p >> instr [Brf elselabel] >>
  73         t >> instr [Bra endiflabel, Lbl elselabel] >>
  74         e >> instr [Lbl endiflabel]
  75     bottom msg = instr [Error msg]
  76
  77 instance Function () Compiler where
  78     fun def = Main $
  79         freshLabel >>= \funlabel->
  80         let g :- m = def (\()->instr [Jsr funlabel])
  81         in  liftFunction funlabel 0 (g ()) >> unmain m
  82
  83 instance Function (Compiler a) Compiler where
  84     fun def = Main $
  85         freshLabel >>= \funlabel->
  86         let g :- m = def (\a->a >> instr [Jsr funlabel])
  87         in  liftFunction funlabel 1 (g (instr [Arg 0])) >> unmain m
  88
  89 instance Function (Compiler a, Compiler b) Compiler where
  90     fun def = Main $
  91         freshLabel >>= \funlabel->
  92         let g :- m = def (\(a, b)->a >> b >> instr [Jsr funlabel])
  93         in  liftFunction funlabel 2 (g (instr [Arg 1], instr [Arg 0])) >> unmain m
  94
  95 instance Function (Compiler a, Compiler b, Compiler c) Compiler where
  96     fun def = Main $
  97         freshLabel >>= \funlabel->
  98         let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel])
  99         in  liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
 100
 101 instance Function (Compiler a, Compiler b, Compiler c, Compiler d) Compiler where
 102     fun def = Main $
 103         freshLabel >>= \funlabel->
 104         let g :- m = def (\(a, b, c, d)->a >> b >> c >> d >> instr [Jsr funlabel])
 105         in  liftFunction funlabel 4 (g (instr [Arg 3], instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
 106
 107 liftFunction :: Int -> Int -> Compiler a -> Compiler ()
 108 liftFunction lbl nargs body = do
 109     is <- snd <$> censor (\_->[]) (listen body)
 110     let instructions = Lbl lbl : is ++ [Ret nargs]
 111     modify (\s->s { functions=DM.insert lbl instructions $ functions s })
 112
 113 data Instr
 114     = Push Int | Pop Int
 115     | Add | Sub | Mul | Div | Neg
 116     | And | Or | Not
 117     | Eq | Neq | Le | Ge | Leq | Geq
 118     | Lbl Int | Bra Int | Brf Int
 119     | Str Int | Ldr Int
 120     | Sth Int | Ldh Int
 121     | Jsr Int | Ret Int | Arg Int
 122     | Halt | Error String
 123   deriving Show
 124
 125 data Registers = Registers
 126     { pc :: Int
 127     , hp :: Int
 128     , sp :: Int
 129     , mp :: Int
 130     , gp :: DM.Map Int Int
 131     }
 132   deriving Show
 133
 134 interpret :: Int -> [Instr] -> Int
 135 interpret memsize prog = runSTArray resultStack ! (memsize-1)
 136   where
 137     resultStack :: ST s (STArray s Int Int)
 138     resultStack = join $ int
 139         <$> newListArray (0, length prog) prog
 140         <*> newArray (0, memsize-1) 0
 141         <*> pure (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
 142
 143     pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 144     pushh memory value reg = do
 145         writeArray memory (hp reg) value
 146         pure (reg { hp = hp reg + 1} )
 147
 148     loadh :: STArray s Int Int -> Int -> Registers -> ST s Registers
 149     loadh memory hptr registers = readArray memory hptr >>= flip (push memory) registers
 150
 151     push :: STArray s Int Int -> Int -> Registers -> ST s Registers
 152     push memory value reg = do
 153         writeArray memory (sp reg) value
 154         pure (reg { sp = sp reg - 1} )
 155
 156     pop :: STArray s Int Int -> Registers -> ST s (Registers, Int)
 157     pop memory reg = do
 158         v <- readArray memory (sp reg + 1)
 159         pure (reg { sp = sp reg + 1}, v)
 160
 161     popn :: STArray s Int Int -> Int -> Registers -> ST s (Registers, [Int])
 162     popn _ 0 reg = pure (reg, [])
 163     popn memory n reg = do
 164         (reg', v) <- pop memory reg
 165         (reg'', vs) <- popn memory (n - 1) reg'
 166         pure (reg'', v:vs)
 167
 168     bop :: (Int -> Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 169     bop op memory reg = do
 170         (reg1, r) <- pop memory reg
 171         uop (flip op r) memory reg1
 172
 173     uop :: (Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
 174     uop op memory reg = do
 175         (reg1, r) <- pop memory reg
 176         push memory (op r) reg1
 177
 178     int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
 179     int program memory registers = do
 180         instruction <- readArray program $ pc registers
 181         let reg = registers { pc = pc registers + 1 }
 182         case instruction of
 183             Str r -> do
 184                 (reg', v) <- pop memory reg
 185                 int program memory $ reg' { gp = DM.insert r v (gp reg')}
 186             Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
 187             Pop n -> popn memory n reg >>= int program memory . fst
 188             Push v -> push memory v reg >>= int program memory
 189             Add -> bop (+) memory reg >>= int program memory
 190             Sub -> bop (-) memory reg >>= int program memory
 191             Mul -> bop (*) memory reg >>= int program memory
 192             Div -> bop div memory reg >>= int program memory
 193             Neg -> uop negate memory reg >>= int program memory
 194             And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory
 195             Or  -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
 196             Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory
 197             Eq  -> bop ((b2i .) . (==)) memory reg >>= int program memory
 198             Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory
 199             Le  -> bop ((b2i .) . (<)) memory reg >>= int program memory
 200             Ge  -> bop ((b2i .) . (>)) memory reg >>= int program memory
 201             Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory
 202             Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory
 203             Lbl _ -> int program memory reg
 204             Bra l -> branch l program reg >>= int program memory
 205             Brf l -> do
 206                 (reg', v) <- pop memory reg
 207                 reg'' <- if i2b v then pure reg' else branch l program reg'
 208                 int program memory reg''
 209             Sth n ->
 210                     popn memory n reg
 211                 >>= uncurry (foldM $ flip $ pushh memory)
 212                 >>= push memory (hp reg + n - 1)
 213                 >>= int program memory
 214             Ldh n -> pop memory reg >>= \(reg', hptr)->loadh memory (hptr - n - 1) reg'
 215                 >>= int program memory
 216             Jsr i -> push memory (pc reg) reg
 217                 >>= push memory (mp reg)
 218                 >>= branch i program
 219                 >>= \r->int program memory (r { mp = sp r})
 220             Ret n -> do
 221                 (reg1, rval:omp:ra:_) <- popn memory (3+n) reg
 222                 reg2 <- push memory rval reg1
 223                 int program memory $ reg2 { pc=ra, mp=omp }
 224             Arg n -> do
 225                 v <- readArray memory (mp reg + 3 + n)
 226                 push memory v reg >>= int program memory
 227             Halt -> pure memory
 228             Error msg -> fail msg
 229
 230     branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers
 231     branch label program reg = case pc reg of
 232         -1 -> getBounds program >>= \(_, m)->branch label program $ reg { pc = m - 1}
 233         _ -> readArray program (pc reg) >>= \case
 234             Lbl l | label == l -> pure $ reg
 235             _ -> branch label program $ reg { pc = pc reg - 1 }
 236
 237 b2i :: Bool -> Int
 238 b2i True = 1
 239 b2i False = 0
 240
 241 i2b :: Int -> Bool
 242 i2b 0 = False
 243 i2b _ = True