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

Trying to limit some of the instructions we do in Karatsuba multiplication ...

Browse Source
This commit is contained in:
Adam Wick
2020-04-26 19:53:40 -07:00
parent 9ee668daad
commit a622aa9cc9
1 changed files with 96 additions and 46 deletions
Download Patch File Download Diff File Expand all files Collapse all files

116
generation/src/Karatsuba.hs
View File

@@ -6,9 +6,12 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
module Karatsuba( module Karatsuba(
Instruction(..) Instruction(..)
, InstructionData(..)
, Variable
, runChecks , runChecks
, runQuickCheck , runQuickCheck
, generateInstructions , generateInstructions
, variableName
) )
where where
@@ -20,31 +23,37 @@ import Data.LargeWord
import Data.List import Data.List
import Data.Map.Strict(Map) import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map 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 ((.&.))
import Debug.Trace
-- this drives the testing -- this drives the testing
inputWordSize :: Int inputWordSize :: Int
inputWordSize = 5 inputWordSize = 5
generateInstructions :: Word -> [Instruction] data InstructionData = InstructionData {
generateInstructions numdigits = idInstructions :: [Instruction],
let (baseVec, baseInstrs) = runMath $ do x <- V.replicateM (fromIntegral numdigits) (genDigit 1) idInput1 :: [Variable],
y <- V.replicateM (fromIntegral numdigits) (genDigit 1) idInput2 :: [Variable],
karatsuba x y idOutput :: [Variable]
in baseInstrs }
-- foldl replaceVar baseInstrs varRenames generateInstructions :: Word -> InstructionData
-- where generateInstructions numdigits =
-- x = rename "x" (V.replicate (fromIntegral numdigits) (D "" 1)) let (baseID, baseInstrs) = runMath $ do (x, xinstrs) <- listen $ V.replicateM (fromIntegral numdigits) (genDigit 1)
-- y = rename "y" (V.replicate (fromIntegral numdigits) (D "" 1)) (y, yinstrs) <- listen $ V.replicateM (fromIntegral numdigits) (genDigit 1)
-- (baseVec, baseInstrs) = runMath (karatsuba x y) res <- karatsuba x y
-- res = rename "res" baseVec return InstructionData {
-- varRenames = zip (map name (V.toList baseVec)) (map name (V.toList res)) idInstructions = xinstrs ++ yinstrs,
idInput1 = map name (V.toList x),
idInput2 = map name (V.toList y),
idOutput = map name (V.toList res)
}
(preps, reals) = splitAt (length (idInstructions baseID)) baseInstrs
in baseID{ idInstructions = preps ++ simplifyConstants reals }
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
@@ -56,6 +65,9 @@ generateInstructions numdigits =
newtype Variable = V Word newtype Variable = V Word
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
variableName :: Variable -> String
variableName (V x) = "t" ++ show x
-- 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 Variable [Variable] data Instruction = Add Variable [Variable]
@@ -113,22 +125,48 @@ run env instrs =
[] -> env [] -> env
(x:rest) -> run (step env x) rest (x:rest) -> run (step env x) rest
replaceVar :: [Instruction] -> (Variable, Variable) -> [Instruction] simplifyConstants :: [Instruction] -> [Instruction]
replaceVar ls (from, to) = map replace ls simplifyConstants instrs = go instrs Map.empty Map.empty Map.empty
where where
replace x = go [] _ _ _ = []
case x of go (instr:rest) consts64 consts128 remaps =
Add outname items -> Add (sub outname) (map sub items) case instr of
CastDown outname item -> CastDown (sub outname) (sub item) Add outname items ->
CastUp outname item -> CastUp (sub outname) (sub item) Add outname (map (replace remaps) items) : go rest consts64 consts128 remaps
Complement outname item -> Complement (sub outname) (sub item)
Declare64 outname val -> Declare64 (sub outname) val CastDown outname item ->
Declare128 outname val -> Declare128 (sub outname) val CastDown outname (replace remaps item) : go rest consts64 consts128 remaps
Mask outname item mask -> Mask (sub outname) (sub item) mask
Multiply outname items -> Multiply (sub outname) (map sub items) CastUp outname item ->
ShiftR outname item amt -> ShiftR (sub outname) (sub item) amt CastUp outname (replace remaps item) : go rest consts64 consts128 remaps
sub x | x == from = to
| otherwise = x Complement outname item ->
Complement outname (replace remaps item) : go rest consts64 consts128 remaps
Declare64 outname val | Just outname' <- Map.lookup val consts64 ->
go rest consts64 consts128 (Map.insert outname outname' remaps)
Declare64 outname val ->
Declare64 outname val : go rest (Map.insert val outname consts64) consts128 remaps
Declare128 outname val | Just outname' <- Map.lookup val consts128 ->
go rest consts64 consts128 (Map.insert outname outname' remaps)
Declare128 outname val ->
Declare128 outname val : go rest consts64 (Map.insert val outname consts128) remaps
Mask outname item mask ->
Mask outname (replace remaps item) mask : go rest consts64 consts128 remaps
Multiply outname items ->
Multiply outname (map (replace remaps) items) : go rest consts64 consts128 remaps
ShiftR outname item amt ->
ShiftR outname (replace remaps item) amt : go rest consts64 consts128 remaps
replace :: Map Variable Variable -> Variable -> Variable
replace remaps item = Map.findWithDefault item item remaps
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
@@ -593,14 +631,19 @@ prop_KaratsubaWorks l x y =
y' = abs y `mod` (2 ^ (64 * l')) y' = abs y `mod` (2 ^ (64 * l'))
prop_InstructionsWork :: Int -> Integer -> Integer -> Bool prop_InstructionsWork' ::
prop_InstructionsWork l x y = ([Instruction] -> [Instruction]) ->
Int ->
Integer ->
Integer ->
Bool
prop_InstructionsWork' f l x y =
let (value, instructions) = runMath $ do numx <- convertTo l' x' let (value, instructions) = runMath $ do numx <- convertTo l' x'
numy <- convertTo l' y' numy <- convertTo l' y'
karatsuba numx numy karatsuba numx numy
resGMP = x' * y' resGMP = x' * y'
resKaratsuba = convertFrom value resKaratsuba = convertFrom value
(endEnvironment, _) = run (Map.empty, Map.empty) instructions (endEnvironment, _) = run (Map.empty, Map.empty) (f instructions)
instrVersion = V.map (getv endEnvironment . name) value instrVersion = V.map (getv endEnvironment . name) value
in (resGMP == resKaratsuba) && (value == instrVersion) in (resGMP == resKaratsuba) && (value == instrVersion)
where where
@@ -612,6 +655,12 @@ prop_InstructionsWork l x y =
Nothing -> error ("InstrProp lookup failure: " ++ show n) Nothing -> error ("InstrProp lookup failure: " ++ show n)
Just v -> D n v Just v -> D n v
prop_InstructionsWork :: Int -> Integer -> Integer -> Bool
prop_InstructionsWork = prop_InstructionsWork' id
prop_SimplifiedInstructionsWork :: Int -> Integer -> Integer -> Bool
prop_SimplifiedInstructionsWork = prop_InstructionsWork' simplifyConstants
prop_InstructionsConsistent :: Int -> Integer -> Integer -> Integer -> Integer -> Bool prop_InstructionsConsistent :: Int -> Integer -> Integer -> Integer -> Integer -> Bool
prop_InstructionsConsistent l a b x y = prop_InstructionsConsistent l a b x y =
let (_, instrs1) = runMath (karatsuba' a' b') let (_, instrs1) = runMath (karatsuba' a' b')
@@ -659,4 +708,5 @@ runChecks =
runQuickCheck "Mul3 Works " prop_Mul3Works runQuickCheck "Mul3 Works " prop_Mul3Works
runQuickCheck "Karatsuba Works " prop_KaratsubaWorks runQuickCheck "Karatsuba Works " prop_KaratsubaWorks
runQuickCheck "Instructions Work " prop_InstructionsWork runQuickCheck "Instructions Work " prop_InstructionsWork
runQuickCheck "Simpl. Instructions Work " prop_SimplifiedInstructionsWork
runQuickCheck "Generation Consistent " prop_InstructionsConsistent runQuickCheck "Generation Consistent " prop_InstructionsConsistent