SlowComp.hs 6.01 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
{-# LANGUAGE TypeFamilies, GADTs, EmptyDataDecls, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

module SlowComp where

import Control.Monad
import Control.Monad.State

-------------------------------------------------------------------------------
-- Usual Peano integers.


class NatInt a where
	natInt :: a -> Int

data D0 n = D0 {d0Arg :: n}
data D1 n = D1 {d1Arg :: n}

data C0
data C1

class DPosInt n where posInt :: n -> (Int,Int)
instance DPosInt () where posInt _ = (0,1)
instance DPosInt n => DPosInt (D0 n) where
	posInt a = (dsum,w*2)
		where
			(dsum,w) = posInt $ d0Arg a
instance DPosInt n => DPosInt (D1 n) where
	posInt a = (dsum+w,w*2)
		where
			(dsum,w) = posInt $ d1Arg a

instance NatInt () where natInt _ = 0
instance DPosInt n => NatInt (D0 n) where natInt a = fst $ posInt a
instance DPosInt n => NatInt (D1 n) where natInt a = fst $ posInt a

type family DRev a
type instance DRev a = DRev' a ()

type family DRev' x acc
type instance DRev' () acc = acc
type instance DRev' (D0 a) acc = DRev' a (D0 acc)
type instance DRev' (D1 a) acc = DRev' a (D1 acc)

type family DAddC c a b
type instance DAddC C0 (D0 a) (D0 b) = D0 (DAddC C0 a b)
type instance DAddC C0 (D1 a) (D0 b) = D1 (DAddC C0 a b)
type instance DAddC C0 (D0 a) (D1 b) = D1 (DAddC C0 a b)
type instance DAddC C0 (D1 a) (D1 b) = D0 (DAddC C1 a b)
type instance DAddC C1 (D0 a) (D0 b) = D1 (DAddC C0 a b)
type instance DAddC C1 (D1 a) (D0 b) = D0 (DAddC C1 a b)
type instance DAddC C1 (D0 a) (D1 b) = D0 (DAddC C1 a b)
type instance DAddC C1 (D1 a) (D1 b) = D1 (DAddC C1 a b)
type instance DAddC C0 ()     ()     = ()
type instance DAddC C1 ()     ()     = D1 ()
type instance DAddC c  (D0 a) ()     = DAddC c (D0 a) (D0 ())
type instance DAddC c  (D1 a) ()     = DAddC c (D1 a) (D0 ())
type instance DAddC c  ()     (D0 b) = DAddC c (D0 b) (D0 ())
type instance DAddC c  ()     (D1 b) = DAddC c (D1 b) (D0 ())

type family DNorm a
type instance DNorm () = D0 ()
type instance DNorm (D0 ()) = D0 ()
type instance DNorm (D0 (D1 a)) = D1 a
type instance DNorm (D0 (D0 a)) = DNorm a
type instance DNorm (D1 a) = D1 a

type family DPlus a b
type instance DPlus a b = DNorm (DRev (DAddC C0 (DRev a) (DRev b)))

type family DDepth a
type instance DDepth () = D0 ()
type instance DDepth (D0 ()) = D0 ()
type instance DDepth (D1 ()) = D1 ()
type instance DDepth (D1 (D0 n)) = DPlus ONE (DDepth (D1 n))
type instance DDepth (D1 (D1 n)) = DPlus ONE (DDepth (D1 n))

type family DLog2 a
type instance DLog2 a = DDepth a

type ZERO = D0 ()

type ONE = D1 ()
type TWO = DPlus ONE ONE
type THREE = DPlus ONE TWO
type FOUR = DPlus TWO TWO
type FIVE = DPlus ONE FOUR
type SIX = DPlus TWO FOUR
type SEVEN = DPlus ONE SIX
type EIGHT = DPlus FOUR FOUR
type NINE = DPlus FOUR FIVE
type TEN = DPlus EIGHT TWO
type SIZE8  = EIGHT
type SIZE9  = NINE
type SIZE10 = TEN
type SIZE12 = DPlus SIX SIX
type SIZE15 = DPlus EIGHT SEVEN
type SIZE16 = DPlus EIGHT EIGHT
type SIZE17 = DPlus ONE SIZE16
type SIZE24 = DPlus SIZE8 SIZE16
type SIZE32 = DPlus SIZE8 SIZE24
type SIZE30 = DPlus SIZE24 SIX

-------------------------------------------------------------------------------
-- Description of CPU.

class CPU cpu where
	-- register address.
	type RegAddrSize cpu
	-- register width
	type RegDataSize cpu
	-- immediate width.
	type ImmSize cpu
	-- variables in CPU - register indices, command format variables, etc.
	type CPUVars cpu :: * -> *

data Const size = Const Integer

data Var cpu size where
	Temp :: Int -> Var cpu size
	Var :: CPUVars cpu size -> Var cpu size

-------------------------------------------------------------------------------
-- Command description monad.

data Command cpu where
	Command :: (Var cpu size) -> (Operation cpu size) -> Command cpu

type RegVar cpu = Var cpu (RegDataSize cpu)
type Immediate cpu = Const (ImmSize cpu)

data Operation cpu resultSize where
	Add :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu)
	Sub :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu)
	

type CDM cpu a = StateT (Int, [Command cpu]) IO a

($=) :: CPU cpu => Var cpu size -> Operation cpu size -> CDM cpu ()
var $= op = modify $ \(cnt,ops) -> (cnt,ops ++ [Command var op])

tempVar :: CPU cpu => CDM cpu (Var cpu size)
tempVar = do
	cnt <- liftM fst get
	modify $ \(_,cmds) -> (cnt+1,cmds)
	return $ Temp cnt

op :: CPU cpu => Operation cpu size -> CDM cpu (Var cpu size)
op operation = do
	v <- tempVar
	v $= operation
	return v

-------------------------------------------------------------------------------
-- Dummy CPU.

data DummyCPU = DummyCPU

data DummyVar size where
	DummyFlag :: Flag -> DummyVar ONE
	DummyReg :: Int -> DummyVar SIZE16
	DummyZero :: DummyVar SIZE16

data Flag = C | Z | N | V

instance CPU DummyCPU where
	type RegAddrSize DummyCPU = FIVE
	type RegDataSize DummyCPU = SIZE16
	type ImmSize DummyCPU = SIZE12
	type CPUVars DummyCPU = DummyVar

-------------------------------------------------------------------------------
-- Long compiling program.

cnst :: Integer -> Either (Immediate DummyCPU) (RegVar DummyCPU)
cnst x = Left (Const x)

longCompilingProgram :: CDM DummyCPU ()
longCompilingProgram = do
-- the number of lines below greatly affects compilation time.
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	x10 <- op $ Add (Var DummyZero) (cnst 10)
	return ()