module Language.TRM.Programs (
succBB'
, plusBB'
, compare'
, clear
, move
, copy
, compare
, succBB
, addBB
, multBB
, exptBB
, double
, unaryToBB
, bbToUnary
) where
import Language.TRM.Base
import Control.Monad
import Prelude hiding (compare)
succBB' :: Word
succBB' = "1##### 1111111111 111### 1111111111### 11# 1##### 111111### 111### 11## 1111#### 11# 111111#### 1111### 11## 1111111111 111#### 11# 11##### 111111### 111### 1## 1111#### 1# 111111####"
plusBB' :: Word
plusBB' = "1##### 111### 111111### 111111111### 11##### 1111111111 11111111111 11111111111 111### 1111111111 11111111111 11111### 1111111111 11111111111 111111### 11##### 1111111111 11111111111 11### 1111111111 11111111111 1111111### 1111111111 11111111111### 11##### 1111111111 11111111111### 1111111111 11111111### 1111111111 111111111### 1##### 111### 111111### 111111111### 11##### 1111111111 1### 1111111111 111111### 111111111### 11##### 1111111111 111### 1111111111### 1111111111 1### 11##### 111### 11111111### 1### 111# 1111111111 11111111111 11111111111 1#### 111## 1111111111 11111111111 11111111111 111#### 111# 1111111111 11111111111#### 111## 1111111111 11111111111 11#### 1### 111##### 111111### 111### 1## 1111#### 1# 111111####"
compare' :: Word
compare' = "1##### 111111### 111111111### 11##### 1111111111 1### 1111111111### 111111#### 11##### 1111111111 11111### 111111### 11111### 11##### 111### 1111111111 111#### 1### 1##### 111### 11#### 111#### 11##### 1111### 11#### 111#### 1#"
clear :: Register
-> LComp ()
clear r =
do_ $ \continue break ->
cond r break continue continue
move :: Register
-> Register
-> LComp ()
move src dest =
do_ $ \continue break ->
cond src
break
(snocOne dest >> continue)
(snocHash dest >> continue)
copy :: Register
-> Register
-> LComp ()
copy src dest = do
tmp <- freshReg
do_ $ \continue break ->
cond src
break
(do snocOne dest ; snocOne tmp ; continue)
(do snocHash dest ; snocHash tmp ; continue)
move tmp src
compare :: Register -> Register -> LComp ()
compare r1 r2 = do
[true, false, clear1, clear2] <- replicateM 4 freshLabel
do_ $ \continue _ ->
cond r1
(cond r2 (goto true) (goto clear2) (goto clear2))
(cond r2 (goto clear1) continue (goto clear1))
(cond r2 (goto clear1) (goto clear1) continue )
label clear1
clear r1
label clear2
clear r2
goto false
label true
snocOne r1
label false
succBB :: Register
-> LComp ()
succBB r = do
tmp <- freshReg
do_ $ \continue break ->
cond r
(do snocOne tmp ; break)
(do snocHash tmp ; continue)
(do snocOne tmp ; move r tmp ; break)
move tmp r
addBB :: Register -> Register -> LComp ()
addBB r1 r2 = do
[r3, r4, r5, r6] <- replicateM 4 freshReg
recCase <- freshLabel
snocHash r3 >> move r1 r4
do_ $ \continue break -> do
copy r2 r5
copy r3 r6
compare r5 r6
cond r5 (goto recCase) break (goto recCase)
label recCase
succBB r4
succBB r3
continue
clear r1 >> clear r2 >> clear r3
move r4 r1
multBB :: Register -> Register -> LComp ()
multBB r1 r2 = do
[r3, r4, r5, r6] <- replicateM 4 freshReg
recCase <- freshLabel
snocHash r3 >> snocHash r4
do_ $ \continue break -> do
copy r2 r5
copy r3 r6
compare r5 r6
cond r5 (goto recCase) break (goto recCase)
label recCase
copy r1 r5
move r4 r6
addBB r5 r6
move r5 r4
succBB r3
continue
clear r1 >> clear r2 >> clear r3
move r4 r1
exptBB :: Register -> Register -> LComp ()
exptBB r1 r2 = do
[r3, r4, r5, r6] <- replicateM 4 freshReg
recCase <- freshLabel
snocHash r3 >> snocOne r4
do_ $ \continue break -> do
copy r2 r5
copy r3 r6
compare r5 r6
cond r5 (goto recCase) break (goto recCase)
label recCase
copy r1 r5
move r4 r6
multBB r5 r6
move r5 r4
succBB r3
continue
clear r1 >> clear r2 >> clear r3
move r4 r1
unaryToBB :: Register -> Register -> LComp ()
unaryToBB src acc = do
snocOne acc
do_ $ \continue break -> do
cond src
break
(do succBB acc ; continue)
break
move acc src
double :: Register -> Register -> LComp ()
double r1 r2 = do copy r1 r2 ; move r2 r1
bbToUnary :: Register -> LComp ()
bbToUnary src = do
[acc, pos, t1] <- replicateM 3 freshReg
snocOne acc
snocOne pos
do_ $ \continue break -> do
cond src
break
(do copy pos acc ; double pos t1 ; continue)
(do double pos t1 ; continue)
clear pos
move acc src