acw/cryptonum
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[CHECKPOINT] Adjust the Karatsuba implementation to abstract Variables from Strings

Browse Source
This commit is contained in:
Adam Wick
2020-04-12 19:52:00 -07:00
parent 2baa5f070d
commit 0483bb8692
2 changed files with 291 additions and 239 deletions
Download Patch File Download Diff File Expand all files Collapse all files

357
generation/src/Karatsuba.hs
View File

@@ -23,6 +23,7 @@ import qualified Data.Map.Strict as Map
import Data.Vector(Vector, (!?)) import Data.Vector(Vector, (!?))
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word import Data.Word
import Debug.Trace
import Prelude hiding (fail) import Prelude hiding (fail)
import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck hiding ((.&.))
@@ -31,13 +32,19 @@ inputWordSize :: Int
inputWordSize = 5 inputWordSize = 5
generateInstructions :: Word -> [Instruction] generateInstructions :: Word -> [Instruction]
generateInstructions numdigits = foldl replaceVar baseInstrs varRenames generateInstructions numdigits =
where let (baseVec, baseInstrs) = runMath $ do x <- V.replicateM (fromIntegral numdigits) (genDigit 1)
x = rename "x" (V.replicate (fromIntegral numdigits) (D "" 1)) y <- V.replicateM (fromIntegral numdigits) (genDigit 1)
y = rename "y" (V.replicate (fromIntegral numdigits) (D "" 1)) karatsuba x y
(baseVec, baseInstrs) = runMath (karatsuba x y) in baseInstrs
res = rename "res" baseVec
varRenames = zip (map name (V.toList baseVec)) (map name (V.toList res)) -- foldl replaceVar baseInstrs varRenames
-- where
-- x = rename "x" (V.replicate (fromIntegral numdigits) (D "" 1))
-- y = rename "y" (V.replicate (fromIntegral numdigits) (D "" 1))
-- (baseVec, baseInstrs) = runMath (karatsuba x y)
-- res = rename "res" baseVec
-- varRenames = zip (map name (V.toList baseVec)) (map name (V.toList res))
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
@@ -46,28 +53,31 @@ generateInstructions numdigits = foldl replaceVar baseInstrs varRenames
-- --
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
newtype Variable = V String
deriving (Eq, Ord, Show)
-- these are in Intel form, as I was corrupted young, so the first argument -- these are in Intel form, as I was corrupted young, so the first argument
-- is the destination and the rest are the arguments. -- is the destination and the rest are the arguments.
data Instruction = Add String [String] data Instruction = Add Variable [Variable]
| CastDown String String | CastDown Variable Variable
| CastUp String String | CastUp Variable Variable
| Complement String String | Complement Variable Variable
| Declare64 String Word64 | Declare64 Variable Word64
| Declare128 String Word128 | Declare128 Variable Word128
| Mask String String Word128 | Mask Variable Variable Word128
| Multiply String [String] | Multiply Variable [Variable]
| ShiftR String String Int | ShiftR Variable Variable Int
deriving (Eq, Show) deriving (Eq, Show)
class Declarable a where class Declarable a where
declare :: String -> a -> Instruction declare :: Variable -> a -> Instruction
instance Declarable Word64 where instance Declarable Word64 where
declare n x = Declare64 n x declare n x = Declare64 n x
instance Declarable Word128 where instance Declarable Word128 where
declare n x = Declare128 n x declare n x = Declare128 n x
type Env = (Map String Word64, Map String Word128) type Env = (Map Variable Word64, Map Variable Word128)
step :: Env -> Instruction -> Env step :: Env -> Instruction -> Env
step (env64, env128) i = step (env64, env128) i =
@@ -91,12 +101,11 @@ step (env64, env128) i =
ShiftR outname item amt -> ShiftR outname item amt ->
(env64, Map.insert outname (getv env128 item `shiftR` amt) env128) (env64, Map.insert outname (getv env128 item `shiftR` amt) env128)
where where
getv :: Map Variable a -> Variable -> a
getv env s = getv env s =
case Map.lookup s env of case Map.lookup s env of
Nothing -> Nothing -> error ("Failure to find key '" ++ show s ++ "'")
error ("Failure to find key '" ++ s ++ "'") Just v -> v
Just v ->
v
run :: Env -> [Instruction] -> Env run :: Env -> [Instruction] -> Env
run env instrs = run env instrs =
@@ -104,7 +113,7 @@ run env instrs =
[] -> env [] -> env
(x:rest) -> run (step env x) rest (x:rest) -> run (step env x) rest
replaceVar :: [Instruction] -> (String, String) -> [Instruction] replaceVar :: [Instruction] -> (Variable, Variable) -> [Instruction]
replaceVar ls (from, to) = map replace ls replaceVar ls (from, to) = map replace ls
where where
replace x = replace x =
@@ -138,10 +147,10 @@ instance MonadFail Math where
emit :: Instruction -> Math () emit :: Instruction -> Math ()
emit instr = tell [instr] emit instr = tell [instr]
gensym :: String -> Math String newVariable :: Math Variable
gensym base = newVariable =
do x <- state (\ i -> (i, i + 1)) do x <- state (\ i -> (i, i + 1))
return (base ++ show x) return (V (show x))
runMath :: Math a -> (a, [Instruction]) runMath :: Math a -> (a, [Instruction])
runMath m = evalRWS (unMath m) () 0 runMath m = evalRWS (unMath m) () 0
@@ -153,14 +162,14 @@ runMath m = evalRWS (unMath m) () 0
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
data Digit size = D { data Digit size = D {
name :: String name :: Variable
, digit :: size , digit :: size
} }
deriving (Eq,Show) deriving (Eq,Show)
genDigit :: Declarable size => String -> size -> Math (Digit size) genDigit :: Declarable size => size -> Math (Digit size)
genDigit nm x = genDigit x =
do newName <- gensym nm do newName <- newVariable
emit (declare newName x) emit (declare newName x)
return D{ return D{
name = newName name = newName
@@ -169,60 +178,60 @@ genDigit nm x =
embiggen :: Digit Word64 -> Math (Digit Word128) embiggen :: Digit Word64 -> Math (Digit Word128)
embiggen x = embiggen x =
do newName <- gensym ("big_" ++ name x) do newName <- newVariable
emit (CastUp newName (name x)) emit (CastUp newName (name x))
return (D newName (fromIntegral (digit x))) return (D newName (fromIntegral (digit x)))
bottomBits :: Digit Word128 -> Math (Digit Word64) bottomBits :: Digit Word128 -> Math (Digit Word64)
bottomBits x = bottomBits x =
do newName <- gensym ("norm_" ++ name x) do newName <- newVariable
emit (CastDown newName (name x)) emit (CastDown newName (name x))
return (D newName (fromIntegral (digit x))) return (D newName (fromIntegral (digit x)))
oneDigit :: Math (Digit Word64) oneDigit :: Math (Digit Word64)
oneDigit = genDigit "one" 1 oneDigit = genDigit 1
bigZero :: Math (Digit Word128) bigZero :: Math (Digit Word128)
bigZero = genDigit "zero" 0 bigZero = genDigit 0
(|+|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128) (|+|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128)
(|+|) x y = (|+|) x y =
do newName <- gensym "plus" do newName <- newVariable
emit (Add newName [name x, name y]) emit (Add newName [name x, name y])
let digval = digit x + digit y let digval = digit x + digit y
return (D newName digval) return (D newName digval)
sumDigits :: [Digit Word128] -> Math (Digit Word128) sumDigits :: [Digit Word128] -> Math (Digit Word128)
sumDigits ls = sumDigits ls =
do newName <- gensym "sum" do newName <- newVariable
emit (Add newName (map name ls)) emit (Add newName (map name ls))
let digval = sum (map digit ls) let digval = sum (map digit ls)
return (D newName digval) return (D newName digval)
(|*|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128) (|*|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128)
(|*|) x y = (|*|) x y =
do newName <- gensym "times" do newName <- newVariable
emit (Multiply newName [name x, name y]) emit (Multiply newName [name x, name y])
let digval = digit x * digit y let digval = digit x * digit y
return (D newName digval) return (D newName digval)
(|>>|) :: Digit Word128 -> Int -> Math (Digit Word128) (|>>|) :: Digit Word128 -> Int -> Math (Digit Word128)
(|>>|) x s = (|>>|) x s =
do newName <- gensym "shiftr" do newName <- newVariable
emit (ShiftR newName (name x) s) emit (ShiftR newName (name x) s)
let digval = digit x `shiftR` s let digval = digit x `shiftR` s
return (D newName digval) return (D newName digval)
(|&|) :: Digit Word128 -> Word128 -> Math (Digit Word128) (|&|) :: Digit Word128 -> Word128 -> Math (Digit Word128)
(|&|) x m = (|&|) x m =
do newName <- gensym ("masked_" ++ name x) do newName <- newVariable
emit (Mask newName (name x) m) emit (Mask newName (name x) m)
let digval = digit x .&. m let digval = digit x .&. m
return (D newName digval) return (D newName digval)
complementDigit :: Digit Word64 -> Math (Digit Word64) complementDigit :: Digit Word64 -> Math (Digit Word64)
complementDigit x = complementDigit x =
do newName <- gensym ("comp_" ++ name x) do newName <- newVariable
emit (Complement newName (name x)) emit (Complement newName (name x))
return (D newName (complement (digit x))) return (D newName (complement (digit x)))
@@ -234,44 +243,31 @@ complementDigit x =
type Number = Vector (Digit Word64) type Number = Vector (Digit Word64)
instance Arbitrary Number where convertTo :: Int -> Integer -> Math Number
arbitrary = convertTo sz num = V.fromList `fmap` go sz num
do ls <- replicateM inputWordSize (D "" <$> arbitrary)
return (V.fromList ls)
rename :: String -> Number -> Number
rename var num = go 0 num
where where
go :: Word -> Number -> Number go :: Int -> Integer -> Math [Digit Word64]
go i v = go 0 _ =
case v !? 0 of return []
Nothing -> V.empty go x v =
Just x -> D (var ++ show i) (digit x) `V.cons` go (i + 1) (V.drop 1 v) do d <- genDigit (fromIntegral v)
rest <- go (x - 1) (v `shiftR` 64)
convertTo :: Int -> Integer -> Number return (d:rest)
convertTo s = pad . V.unfoldrN s next
where
next 0 = Nothing
next x = Just (D{ name = "", digit = fromIntegral x }, x `shiftR` 64)
pad v | V.length v == s = v
| otherwise = pad (v <> V.singleton D{ name = "", digit = 0})
convertFrom :: Number -> Integer convertFrom :: Number -> Integer
convertFrom n = V.foldr combine 0 n convertFrom n = V.foldr combine 0 n
where where
combine x acc = (acc `shiftL` 64) + fromIntegral (digit x) combine x acc = (acc `shiftL` 64) + fromIntegral (digit x)
prop_ConversionWorksNum :: Number -> Bool
prop_ConversionWorksNum n =
n == convertTo inputWordSize (convertFrom n)
prop_ConversionWorksInt :: Integer -> Bool prop_ConversionWorksInt :: Integer -> Bool
prop_ConversionWorksInt n = prop_ConversionWorksInt n = n' == back
n' == convertFrom (convertTo inputWordSize n) where
where n' = n `mod` (2 ^ (inputWordSize * 64)) n' = abs n `mod` (2 ^ (inputWordSize * 64))
there = fst (runMath (convertTo inputWordSize n'))
back = convertFrom there
zero :: Int -> Math Number zero :: Int -> Math Number
zero s = V.fromList `fmap` replicateM s (genDigit "zero" 0) zero s = V.fromList `fmap` replicateM s (genDigit 0)
empty :: Number -> Bool empty :: Number -> Bool
empty = null empty = null
@@ -282,33 +278,50 @@ size = length
splitDigits :: Int -> Number -> Math (Number, Number) splitDigits :: Int -> Number -> Math (Number, Number)
splitDigits i ls = return (V.splitAt i ls) splitDigits i ls = return (V.splitAt i ls)
prop_SplitDigitsIsntTerrible :: Int -> Number -> Bool prop_SplitDigitsIsntTerrible :: Int -> Int -> Integer -> Bool
prop_SplitDigitsIsntTerrible x n = prop_SplitDigitsIsntTerrible a b n =
let ((left, right), _) = runMath (splitDigits x' n) let a' = a `mod` 20
in n == (left <> right) b' = b `mod` 20
where x' = x `mod` inputWordSize (p, l) | a' > b' = (b', a')
| a' < b' = (a', b')
| otherwise = (a' - 1, a')
in fst $ runMath $ do base <- convertTo l n
(left, right) <- splitDigits p base
return (base == (left <> right))
addZeros :: Int -> Number -> Math Number addZeros :: Int -> Number -> Math Number
addZeros x n = addZeros x n =
do prefix <- zero x do prefix <- zero x
return (prefix <> n) return (prefix <> n)
prop_AddZerosIsShift :: Int -> Number -> Bool prop_AddZerosIsShift :: Int -> Integer -> Bool
prop_AddZerosIsShift x n = prop_AddZerosIsShift x n =
let x' = abs (x `mod` inputWordSize) fst $ runMath $ do base <- convertTo inputWordSize n'
nInt = convertFrom n added <- addZeros x' base
shiftVersion = nInt `shiftL` (x' * 64) let shiftVer = n' `shiftL` (x' * 64)
addVersion = convertFrom (fst (runMath (addZeros x' n))) let mine = convertFrom added
in shiftVersion == addVersion return (shiftVer == mine)
where
x' = abs x `mod` inputWordSize
n' = abs n `mod` (2 ^ (inputWordSize * 64))
padTo :: Int -> Number -> Math Number padTo :: Int -> Number -> Math Number
padTo len num = padTo len num =
do suffix <- zero (len - V.length num) do suffix <- zero (len - V.length num)
return (num <> suffix) return (num <> suffix)
prop_PadToWorks :: Int -> Number -> Property prop_PadToWorks :: Int -> Int -> Integer -> Bool
prop_PadToWorks len num = len >= size num ==> prop_PadToWorks a b num =
convertFrom num == convertFrom (fst (runMath (padTo len num))) fst $ runMath $ do base <- convertTo sz num'
padded <- padTo len base
let newval = convertFrom padded
return (num' == newval)
where
a' = abs a `mod` (inputWordSize * 3)
b' = abs b `mod` (inputWordSize * 3)
(len, sz) | a' >= b' = (max 1 a', max 1 b')
| otherwise = (max 1 b', max 1 a')
num' = abs (num `mod` (2 ^ (64 * sz)))
add2 :: Number -> Number -> Math Number add2 :: Number -> Number -> Math Number
add2 xs ys add2 xs ys
@@ -330,14 +343,18 @@ add2 xs ys
let res' = res <> V.singleton newdigit let res' = res <> V.singleton newdigit
return (res', carry') return (res', carry')
prop_Add2Works :: Number -> Number -> Bool prop_Add2Works :: Int -> Integer -> Integer -> Bool
prop_Add2Works n m = prop_Add2Works l n m =
let nInt = convertFrom n fst $ runMath $ do num1 <- convertTo l' n'
mInt = convertFrom m num2 <- convertTo l' m'
intRes = nInt + mInt res <- add2 num1 num2
(numRes, _) = runMath (add2 n m) let intRes = convertFrom res
numResInt = convertFrom numRes return ((intRes == r) && (size res == l' + 1))
in (size numRes == inputWordSize + 1) && (intRes == numResInt) where
l' = max 1 (abs l `mod` inputWordSize)
n' = abs n `mod` (2 ^ (l' * 64))
m' = abs m `mod` (2 ^ (l' * 64))
r = n' + m'
add3 :: Number -> Number -> Number -> Math Number add3 :: Number -> Number -> Number -> Math Number
add3 x y z add3 x y z
@@ -362,15 +379,20 @@ add3 x y z
let res' = res <> V.singleton digit' let res' = res <> V.singleton digit'
return (res', carry') return (res', carry')
prop_Add3Works :: Number -> Number -> Number -> Bool prop_Add3Works :: Int -> Integer -> Integer -> Integer -> Bool
prop_Add3Works x y z = prop_Add3Works l x y z =
let xInt = convertFrom x fst $ runMath $ do num1 <- convertTo l' x'
yInt = convertFrom y num2 <- convertTo l' y'
zInt = convertFrom z num3 <- convertTo l' z'
intRes = xInt + yInt + zInt res <- add3 num1 num2 num3
(numRes, _) = runMath (add3 x y z) let intRes = convertFrom res
numResInt = convertFrom numRes return ((intRes == r) && (size res == l' + 1))
in (size numRes == inputWordSize + 1) && (intRes == numResInt) where
l' = max 1 (abs l `mod` inputWordSize)
x' = abs x `mod` (2 ^ (l' * 64))
y' = abs y `mod` (2 ^ (l' * 64))
z' = abs z `mod` (2 ^ (l' * 64))
r = x' + y' + z'
sub2 :: Number -> Number -> Math Number sub2 :: Number -> Number -> Math Number
sub2 x y sub2 x y
@@ -383,16 +405,20 @@ sub2 x y
res <- add3 x yinv one res <- add3 x yinv one
return (V.take (size x) res) return (V.take (size x) res)
prop_Sub2Works :: Number -> Number -> Bool prop_Sub2Works :: Int -> Integer -> Integer -> Bool
prop_Sub2Works a b prop_Sub2Works l a b =
| convertFrom a < convertFrom b = prop_Sub2Works b a fst $ runMath $ do num1 <- convertTo l' x
| otherwise = num2 <- convertTo l' y
let aInt = convertFrom a res <- sub2 num1 num2
bInt = convertFrom b let intRes = convertFrom res
intRes = aInt - bInt return (intRes == r)
(numRes, _) = runMath (sub2 a b) where
numResInt = convertFrom numRes l' = max 1 (abs l `mod` inputWordSize)
in intRes == numResInt a' = abs a `mod` (2 ^ (l' * 64))
b' = abs b `mod` (2 ^ (l' * 64))
(x, y) | a' >= b' = (a', b')
| otherwise = (b', a')
r = x - y
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
@@ -413,20 +439,20 @@ mul1 num1 num2
return (V.fromList [z0, z1]) return (V.fromList [z0, z1])
prop_MulNWorks :: Int -> (Number -> Number -> Math Number) -> prop_MulNWorks :: Int -> (Number -> Number -> Math Number) ->
Number -> Number -> Integer -> Integer ->
Bool Bool
prop_MulNWorks nsize f x y = prop_MulNWorks nsize f x y =
let (x', _) = runMath (padTo nsize (V.take nsize x)) fst $ runMath $ do num1 <- convertTo nsize x'
(y', _) = runMath (padTo nsize (V.take nsize y)) num2 <- convertTo nsize y'
xInt = convertFrom x' res <- f num1 num2
yInt = convertFrom y' let resInt = convertFrom res
resInt = xInt * yInt return ((size res == (nsize * 2)) && (resInt == (x' * y')))
(resNum, _) = runMath (f x' y')
in (size x' == nsize) && (size y' == nsize) &&
(size resNum == (nsize * 2)) &&
(resInt == convertFrom resNum)
prop_Mul1Works :: Number -> Number -> Bool where
x' = abs x `mod` (2 ^ (64 * nsize))
y' = abs y `mod` (2 ^ (64 * nsize))
prop_Mul1Works :: Integer -> Integer -> Bool
prop_Mul1Works = prop_MulNWorks 1 mul1 prop_Mul1Works = prop_MulNWorks 1 mul1
mul2 :: Number -> Number -> Math Number mul2 :: Number -> Number -> Math Number
@@ -456,7 +482,7 @@ mul2 num1 num2
dest3 <- bottomBits =<< (l1r1'' |>>| 64) dest3 <- bottomBits =<< (l1r1'' |>>| 64)
return (V.fromList [dest0, dest1, dest2, dest3]) return (V.fromList [dest0, dest1, dest2, dest3])
prop_Mul2Works :: Number -> Number -> Bool prop_Mul2Works :: Integer -> Integer -> Bool
prop_Mul2Works = prop_MulNWorks 2 mul2 prop_Mul2Works = prop_MulNWorks 2 mul2
mul3 :: Number -> Number -> Math Number mul3 :: Number -> Number -> Math Number
@@ -506,7 +532,7 @@ mul3 num1 num2
dest5 <- bottomBits =<< (l2r2' |>>| 64) dest5 <- bottomBits =<< (l2r2' |>>| 64)
return (V.fromList [dest0, dest1, dest2, dest3, dest4, dest5]) return (V.fromList [dest0, dest1, dest2, dest3, dest4, dest5])
prop_Mul3Works :: Number -> Number -> Bool prop_Mul3Works :: Integer -> Integer -> Bool
prop_Mul3Works = prop_MulNWorks 3 mul3 prop_Mul3Works = prop_MulNWorks 3 mul3
karatsuba :: Number -> Number -> Math Number karatsuba :: Number -> Number -> Math Number
@@ -544,43 +570,69 @@ karatsuba num1 num2
az0 <- padTo addsize z0 az0 <- padTo addsize z0
az1 <- padTo addsize z1' az1 <- padTo addsize z1'
az2 <- padTo addsize z2' az2 <- padTo addsize z2'
add3 az2 az1 az0 res <- add3 az2 az1 az0
forM_ (V.drop (m * 2) res) $ \ highDigit ->
-- this will only occur when (size res > (m * 2))
when (digit highDigit /= 0) $
fail "High bit found in Karatsuba result"
return (V.take (m * 2) res)
prop_KaratsubaWorks :: Number -> Number -> Bool prop_KaratsubaWorks :: Int -> Integer -> Integer -> Bool
prop_KaratsubaWorks x y = prop_KaratsubaWorks l x y =
let shouldBe = convertFrom x * convertFrom y fst $ runMath $ do num1 <- convertTo l' x'
monad = karatsuba x y num2 <- convertTo l' y'
myVersion = convertFrom (fst (runMath monad)) res <- karatsuba num1 num2
in shouldBe == myVersion let resInt = convertFrom res
sizeOk = size res == (l' * 2)
valOk = resInt == (x' * y')
return (sizeOk && valOk)
prop_InstructionsWork :: Number -> Number -> Bool
prop_InstructionsWork x y =
let shouldBe = convertFrom x' * convertFrom y'
(mine, instrs) = runMath (karatsuba x' y')
myVersion = convertFrom mine
(endEnv, _) = run startEnv instrs
instrVersion = V.map (getv endEnv . name) mine
in (shouldBe == myVersion) && (mine == instrVersion)
where where
x' = rename "x" x l' = (abs l `mod` (inputWordSize * 2)) + 2
y' = rename "y" y x' = abs x `mod` (2 ^ (64 * l'))
startEnv = (Map.fromList startEnv64, Map.empty) y' = abs y `mod` (2 ^ (64 * l'))
startEnv64 = map (\ d -> (name d, digit d)) (V.toList (x' <> y'))
prop_InstructionsWork :: Int -> Integer -> Integer -> Bool
prop_InstructionsWork l x y =
let (value, instructions) = runMath $ do numx <- convertTo l' x'
numy <- convertTo l' y'
karatsuba numx numy
resGMP = x' * y'
resKaratsuba = convertFrom value
(endEnvironment, _) = run (Map.empty, Map.empty) instructions
instrVersion = V.map (getv endEnvironment . name) value
in (resGMP == resKaratsuba) && (value == instrVersion)
where
l' = max 1 (abs l `mod` inputWordSize)
x' = abs x `mod` (2 ^ (64 * l'))
y' = abs y `mod` (2 ^ (64 * l'))
getv env n = getv env n =
case Map.lookup n env of case Map.lookup n env of
Nothing -> error ("InstrProp lookup failure: " ++ n) Nothing -> error ("InstrProp lookup failure: " ++ show n)
Just v -> D n v Just v -> D n v
prop_InstructionsConsistent :: Number -> Number -> Number -> Number -> Bool prop_InstructionsConsistent :: Int -> Integer -> Integer -> Integer -> Integer -> Bool
prop_InstructionsConsistent a b x y = prop_InstructionsConsistent l a b x y =
let (_, instrs1) = runMath (karatsuba a' b') let (_, instrs1) = runMath (karatsuba' a' b')
(_, instrs2) = runMath (karatsuba x' y') (_, instrs2) = runMath (karatsuba' x' y')
in instrs1 == instrs2 instrs1' = dropWhile isDeclare64 instrs1
instrs2' = dropWhile isDeclare64 instrs2
in instrs1' == instrs2'
where where
a' = rename "p" a l' = max 1 (abs l `mod` inputWordSize)
b' = rename "q" b a' = abs a `mod` (2 ^ (64 * l'))
x' = rename "p" x b' = abs b `mod` (2 ^ (64 * l'))
y' = rename "q" y x' = abs x `mod` (2 ^ (64 * l'))
y' = abs y `mod` (2 ^ (64 * l'))
karatsuba' p q =
do num1 <- convertTo l' p
num2 <- convertTo l' q
karatsuba num1 num2
isDeclare64 i =
case i of
Declare64 _ _ -> True
_ -> False
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
@@ -595,8 +647,7 @@ runQuickCheck testname prop =
runChecks :: IO () runChecks :: IO ()
runChecks = runChecks =
do runQuickCheck "Num -> Int -> Num " prop_ConversionWorksNum do runQuickCheck "Int -> Num -> Int " prop_ConversionWorksInt
runQuickCheck "Int -> Num -> Int " prop_ConversionWorksInt
runQuickCheck "Split Isn't Dumb " prop_SplitDigitsIsntTerrible runQuickCheck "Split Isn't Dumb " prop_SplitDigitsIsntTerrible
runQuickCheck "More 0s is Shift " prop_AddZerosIsShift runQuickCheck "More 0s is Shift " prop_AddZerosIsShift
runQuickCheck "PadTo Does That " prop_PadToWorks runQuickCheck "PadTo Does That " prop_PadToWorks

163
generation/src/Multiply.hs
View File

@@ -205,90 +205,91 @@ generateMultiplier fullmul size inName outName =
in [stmt| $$vec.value[$$(liti)] = $$var; |] in [stmt| $$vec.value[$$(liti)] = $$var; |]
translateInstruction :: Instruction -> Stmt Span translateInstruction :: Instruction -> Stmt Span
translateInstruction instr = translateInstruction instr = undefined
case instr of -- case instr of
Add outname args -> -- Add outname args ->
let outid = mkIdent outname -- let outid = mkIdent outname
args' = map (\x -> [expr| $$x |]) (map mkIdent args) -- args' = map (\x -> [expr| $$x |]) (map mkIdent args)
adds = foldl (\ x y -> [expr| $$(x) + $$(y) |]) -- adds = foldl (\ x y -> [expr| $$(x) + $$(y) |])
(head args') -- (head args')
(tail args') -- (tail args')
in [stmt| let $$outid: u128 = $$(adds); |] -- in [stmt| let $$outid: u128 = $$(adds); |]
CastDown outname arg -> -- CastDown outname arg ->
let outid = mkIdent outname -- let outid = mkIdent outname
inid = mkIdent arg -- inid = mkIdent arg
in [stmt| let $$outid: u64 = $$inid as u64; |] -- in [stmt| let $$outid: u64 = $$inid as u64; |]
CastUp outname arg -> -- CastUp outname arg ->
let outid = mkIdent outname -- let outid = mkIdent outname
inid = mkIdent arg -- inid = mkIdent arg
in [stmt| let $$outid: u128 = $$inid as u128; |] -- in [stmt| let $$outid: u128 = $$inid as u128; |]
Complement outname arg -> -- Complement outname arg ->
let outid = mkIdent outname -- let outid = mkIdent outname
inid = mkIdent arg -- inid = mkIdent arg
in [stmt| let $$outid: u64 = !$$inid; |] -- in [stmt| let $$outid: u64 = !$$inid; |]
Declare64 outname arg -> -- Declare64 outname arg ->
let outid = mkIdent outname -- let outid = mkIdent outname
val = toLit (fromIntegral arg) -- val = toLit (fromIntegral arg)
in [stmt| let $$outid: u64 = $$(val); |] -- in [stmt| let $$outid: u64 = $$(val); |]
Declare128 outname arg -> -- Declare128 outname arg ->
let outid = mkIdent outname -- let outid = mkIdent outname
val = toLit (fromIntegral arg) -- val = toLit (fromIntegral arg)
in [stmt| let $$outid: u128 = $$(val); |] -- in [stmt| let $$outid: u128 = $$(val); |]
Mask outname arg mask -> -- Mask outname arg mask ->
let outid = mkIdent outname -- let outid = mkIdent outname
inid = mkIdent arg -- inid = mkIdent arg
val = toLit (fromIntegral mask) -- val = toLit (fromIntegral mask)
in [stmt| let $$outid: u128 = $$inid & $$(val); |] -- in [stmt| let $$outid: u128 = $$inid & $$(val); |]
Multiply outname args -> -- Multiply outname args ->
let outid = mkIdent outname -- let outid = mkIdent outname
args' = map (\x -> [expr| $$x |]) (map mkIdent args) -- args' = map (\x -> [expr| $$x |]) (map mkIdent args)
muls = foldl (\ x y -> [expr| $$(x) * $$(y) |]) -- muls = foldl (\ x y -> [expr| $$(x) * $$(y) |])
(head args') -- (head args')
(tail args') -- (tail args')
in [stmt| let $$outid: u128 = $$(muls); |] -- in [stmt| let $$outid: u128 = $$(muls); |]
ShiftR outname arg amt -> -- ShiftR outname arg amt ->
let outid = mkIdent outname -- let outid = mkIdent outname
inid = mkIdent arg -- inid = mkIdent arg
val = toLit (fromIntegral amt) -- val = toLit (fromIntegral amt)
in [stmt| let $$outid: u128 = $$inid >> $$(val); |] -- in [stmt| let $$outid: u128 = $$inid >> $$(val); |]
releaseUnnecessary :: [String] -> [Instruction] -> [Instruction] releaseUnnecessary :: [String] -> [Instruction] -> [Instruction]
releaseUnnecessary outkeys instrs = go (Set.fromList outkeys) [] rInstrs releaseUnnecessary outkeys instrs = undefined
where -- go (Set.fromList outkeys) [] rInstrs
rInstrs = reverse instrs -- where
-- rInstrs = reverse instrs
-- --
-- go _ acc [] = acc
-- go required acc (cur:rest)
-- | outVar cur `Set.member` required =
-- go (foldl' (flip Set.insert) required (inVars cur)) (cur:acc) rest
-- | otherwise =
-- go required acc rest
-- --
go _ acc [] = acc --outVar :: Instruction -> String
go required acc (cur:rest) --outVar instr =
| outVar cur `Set.member` required = -- case instr of
go (foldl' (flip Set.insert) required (inVars cur)) (cur:acc) rest -- Add outname _ -> outname
| otherwise = -- CastDown outname _ -> outname
go required acc rest -- CastUp outname _ -> outname
-- Complement outname _ -> outname
outVar :: Instruction -> String -- Declare64 outname _ -> outname
outVar instr = -- Declare128 outname _ -> outname
case instr of -- Mask outname _ _ -> outname
Add outname _ -> outname -- Multiply outname _ -> outname
CastDown outname _ -> outname -- ShiftR outname _ _ -> outname
CastUp outname _ -> outname --
Complement outname _ -> outname --inVars :: Instruction -> [String]
Declare64 outname _ -> outname --inVars instr =
Declare128 outname _ -> outname -- case instr of
Mask outname _ _ -> outname -- Add _ args -> args
Multiply outname _ -> outname -- CastDown _ arg -> [arg]
ShiftR outname _ _ -> outname -- CastUp _ arg -> [arg]
-- Complement _ arg -> [arg]
inVars :: Instruction -> [String] -- Declare64 _ _ -> []
inVars instr = -- Declare128 _ _ -> []
case instr of -- Mask _ arg _ -> [arg]
Add _ args -> args -- Multiply _ args -> args
CastDown _ arg -> [arg] -- ShiftR _ arg _ -> [arg]
CastUp _ arg -> [arg]
Complement _ arg -> [arg]
Declare64 _ _ -> []
Declare128 _ _ -> []
Mask _ arg _ -> [arg]
Multiply _ args -> args
ShiftR _ arg _ -> [arg]
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------