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

Generate multiple modules, instead of one.

Browse Source
This commit is contained in:
Adam Wick
2020-04-26 19:54:22 -07:00
parent a622aa9cc9
commit 1ea75721fd
3 changed files with 141 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
generation/Test.hs
View File

@@ -1,5 +1,4 @@
import Data.Bits hiding (bit) import Data.Bits hiding (bit)
import Debug.Trace
import GHC.Integer.GMP.Internals import GHC.Integer.GMP.Internals
import qualified Karatsuba import qualified Karatsuba
import Numeric import Numeric

206
generation/src/Multiply.hs
View File

@@ -182,17 +182,24 @@ declareUnsafeMulOperators bitsize _ =
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
generateMultiplier :: Bool -> Word -> String -> String -> [Stmt Span] generateMultiplier :: Bool -> Word -> String -> String -> [Stmt Span]
generateMultiplier fullmul size inName outName = generateMultiplier fullmul size inName outName = readIns ++ operations ++ writeOuts
let readIns = map (load "self" "x") [0..size-1] ++
map (load inName "y") [0..size-1]
instructions = releaseUnnecessary outVars (generateInstructions size)
outDigits | fullmul = 2 * size
| otherwise = size
outVars = map (("res" ++) . show) [0..outDigits-1]
operations = map translateInstruction instructions
writeOuts = map (store "res") [0..outDigits-1]
in readIns ++ operations ++ writeOuts
where where
outDigits | fullmul = size * 2
| otherwise = size
--
outVars = map (("res" ++) . show) [0..outDigits-1]
instructionData = generateInstructions size
instrOutputs = take (fromIntegral outDigits) (idOutput instructionData)
instructions = releaseUnnecessary instrOutputs (idInstructions instructionData)
--
readIns = map (load "self" "x") [0..size-1] ++ map (load inName "y") [0..size-1]
writeOuts = map (store "res") [0..outDigits-1]
--
env = zip (idInput1 instructionData) (map (\ i -> "x" ++ show i) [0..size-1]) ++
zip (idInput2 instructionData) (map (\ i -> "y" ++ show i) [0..size-1]) ++
zip (idOutput instructionData) outVars
operations = map (translateInstruction env) instructions
--
load rhs vname i = load rhs vname i =
let liti = toLit i let liti = toLit i
vec = mkIdent rhs vec = mkIdent rhs
@@ -204,92 +211,101 @@ generateMultiplier fullmul size inName outName =
var = mkIdent (vname ++ show i) var = mkIdent (vname ++ show i)
in [stmt| $$vec.value[$$(liti)] = $$var; |] in [stmt| $$vec.value[$$(liti)] = $$var; |]
translateInstruction :: Instruction -> Stmt Span translateInstruction :: [(Variable, String)] -> Instruction -> Stmt Span
translateInstruction instr = undefined translateInstruction env instr =
-- case instr of case instr of
-- Add outname args -> Add outname args ->
-- let outid = mkIdent outname let outid = mkIdentO outname
-- args' = map (\x -> [expr| $$x |]) (map mkIdent args) args' = map (\x -> [expr| $$x |]) (map mkIdentI 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 = mkIdentO outname
-- inid = mkIdent arg inid = mkIdentI 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 = mkIdentO outname
-- inid = mkIdent arg inid = mkIdentI 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 = mkIdentO outname
-- inid = mkIdent arg inid = mkIdentI arg
-- in [stmt| let $$outid: u64 = !$$inid; |] in [stmt| let $$outid: u64 = !$$inid; |]
-- Declare64 outname arg -> Declare64 outname _ | Just inName <- lookup outname env ->
-- let outid = mkIdent outname let outid = mkIdent (variableName outname)
-- val = toLit (fromIntegral arg) inid = mkIdent inName
-- in [stmt| let $$outid: u64 = $$(val); |] in [stmt| let $$outid: u64 = $$inid; |]
-- Declare128 outname arg -> Declare64 outname arg ->
-- let outid = mkIdent outname let outid = mkIdentO outname
-- val = toLit (fromIntegral arg) val = toLit (fromIntegral arg)
-- in [stmt| let $$outid: u128 = $$(val); |] in [stmt| let $$outid: u64 = $$(val); |]
-- Mask outname arg mask -> Declare128 outname arg ->
-- let outid = mkIdent outname let outid = mkIdentO outname
-- inid = mkIdent arg val = toLit (fromIntegral arg)
-- val = toLit (fromIntegral mask) in [stmt| let $$outid: u128 = $$(val); |]
-- in [stmt| let $$outid: u128 = $$inid & $$(val); |] Mask outname arg mask ->
-- Multiply outname args -> let outid = mkIdentO outname
-- let outid = mkIdent outname inid = mkIdentI arg
-- args' = map (\x -> [expr| $$x |]) (map mkIdent args) val = toLit (fromIntegral mask)
-- muls = foldl (\ x y -> [expr| $$(x) * $$(y) |]) in [stmt| let $$outid: u128 = $$inid & $$(val); |]
-- (head args') Multiply outname args ->
-- (tail args') let outid = mkIdentO outname
-- in [stmt| let $$outid: u128 = $$(muls); |] args' = map (\x -> [expr| $$x |]) (map mkIdentI args)
-- ShiftR outname arg amt -> muls = foldl (\ x y -> [expr| $$(x) * $$(y) |])
-- let outid = mkIdent outname (head args')
-- inid = mkIdent arg (tail args')
-- val = toLit (fromIntegral amt) in [stmt| let $$outid: u128 = $$(muls); |]
-- in [stmt| let $$outid: u128 = $$inid >> $$(val); |] ShiftR outname arg amt ->
let outid = mkIdentO outname
inid = mkIdentI arg
val = toLit (fromIntegral amt)
in [stmt| let $$outid: u128 = $$inid >> $$(val); |]
where
mkIdentO :: Variable -> Ident
mkIdentO v | Just x <- lookup v env = mkIdent x
| otherwise = mkIdent (variableName v)
mkIdentI :: Variable -> Ident
mkIdentI = mkIdent . variableName
releaseUnnecessary :: [String] -> [Instruction] -> [Instruction] releaseUnnecessary :: [Variable] -> [Instruction] -> [Instruction]
releaseUnnecessary outkeys instrs = undefined releaseUnnecessary outkeys instrs = go (Set.fromList outkeys) [] rInstrs
-- go (Set.fromList outkeys) [] rInstrs where
-- where rInstrs = reverse instrs
-- rInstrs = reverse instrs --
-- -- go _ acc [] = acc
-- go _ acc [] = acc go required acc (cur:rest)
-- go required acc (cur:rest) | outVar cur `Set.member` required =
-- | outVar cur `Set.member` required = go (foldl' (flip Set.insert) required (inVars cur)) (cur:acc) rest
-- go (foldl' (flip Set.insert) required (inVars cur)) (cur:acc) rest | otherwise =
-- | otherwise = go required acc rest
-- go required acc rest
-- outVar :: Instruction -> Variable
--outVar :: Instruction -> String outVar instr =
--outVar instr = case instr of
-- case instr of Add outname _ -> outname
-- Add outname _ -> outname CastDown outname _ -> outname
-- CastDown outname _ -> outname CastUp outname _ -> outname
-- CastUp outname _ -> outname Complement outname _ -> outname
-- Complement outname _ -> outname Declare64 outname _ -> outname
-- Declare64 outname _ -> outname Declare128 outname _ -> outname
-- Declare128 outname _ -> outname Mask outname _ _ -> outname
-- Mask outname _ _ -> outname Multiply outname _ -> outname
-- Multiply outname _ -> outname ShiftR outname _ _ -> outname
-- ShiftR outname _ _ -> outname
-- inVars :: Instruction -> [Variable]
--inVars :: Instruction -> [String] inVars instr =
--inVars instr = case instr of
-- case instr of Add _ args -> args
-- Add _ args -> args CastDown _ arg -> [arg]
-- CastDown _ arg -> [arg] CastUp _ arg -> [arg]
-- CastUp _ arg -> [arg] Complement _ arg -> [arg]
-- Complement _ arg -> [arg] Declare64 _ _ -> []
-- Declare64 _ _ -> [] Declare128 _ _ -> []
-- Declare128 _ _ -> [] Mask _ arg _ -> [arg]
-- Mask _ arg _ -> [arg] Multiply _ args -> args
-- Multiply _ args -> args ShiftR _ arg _ -> [arg]
-- ShiftR _ arg _ -> [arg]
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------

38
generation/src/RustModule.hs
View File

@@ -10,12 +10,12 @@ module RustModule(
import Control.Monad(forM_, unless) import Control.Monad(forM_, unless)
import Data.Char(toUpper) import Data.Char(toUpper)
import Data.List(isPrefixOf, partition) import Data.List(partition)
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.Maybe(mapMaybe) import Data.Maybe(mapMaybe)
import Language.Rust.Data.Ident(mkIdent) import Language.Rust.Data.Ident(mkIdent)
import Language.Rust.Data.Position(Span, spanOf) import Language.Rust.Data.Position(Position(NoPosition), Span(Span))
import Language.Rust.Pretty(writeSourceFile) import Language.Rust.Pretty(writeSourceFile)
import Language.Rust.Quote(item, sourceFile) import Language.Rust.Quote(item, sourceFile)
import Language.Rust.Syntax(Item(..), SourceFile(..), Visibility(..)) import Language.Rust.Syntax(Item(..), SourceFile(..), Visibility(..))
@@ -64,21 +64,18 @@ generateTasks :: RandomGen g => g -> [RustModule] -> [Word] -> [Task]
generateTasks rng modules sizes = allTheFiles generateTasks rng modules sizes = allTheFiles
where where
allTheFiles = implementationsAndTests ++ allTheFiles = implementationsAndTests ++
[lump "src/signed", lump "src/unsigned"] [lump "i" "src/signed.rs", lump "u" "src/unsigned.rs"]
implementationsAndTests = concatMap generateModules sizes implementationsAndTests = concatMap generateModules sizes
-- --
lump prefix = lump prefix file =
let allFiles = map outputFile implementationsAndTests let moduleNames = map (\s -> prefix ++ show s) sizes
files = filter (prefix `isPrefixOf`) allFiles
moduleFiles = map (drop (length prefix + 1)) files
moduleNames = map (takeWhile (/= '.')) moduleFiles
moduleIdents = map mkIdent moduleNames moduleIdents = map mkIdent moduleNames
types = map (mkIdent . map toUpper) moduleNames types = map (mkIdent . map toUpper) moduleNames
mods = map (\ name -> [item| mod $$name; |]) moduleIdents mods = map (\ name -> [item| mod $$name; |]) moduleIdents
uses = zipWith (\ mname tname -> [item| pub use $$mname::$$tname; |]) uses = zipWith (\ mname tname -> [item| pub use $$mname::$$tname; |])
moduleIdents types moduleIdents types
file = [sourceFile| $@{mods} $@{uses} |] source = [sourceFile| $@{mods} $@{uses} |]
in Task (prefix ++ ".rs") (\hndl -> writeSourceFile hndl file) in Task file (\hndl -> writeSourceFile hndl source)
-- --
generateModules size = generateModules size =
let modules' = filter (\m -> predicate m size sizes) modules let modules' = filter (\m -> predicate m size sizes) modules
@@ -92,18 +89,21 @@ generateTasks rng modules sizes = allTheFiles
| otherwise = | otherwise =
let name = mkIdent (startsWith ++ show size) let name = mkIdent (startsWith ++ show size)
baseInclude = [item| pub use self::base::$$name; |] baseInclude = [item| pub use self::base::$$name; |]
moduleSources = map (generateSubmodule size sizes) modules' isSigned = startsWith == "I"
moduleFile | startsWith == "I" = "src/signed/i" ++ show size ++ ".rs" moduleSources = map (generateSubmodule isSigned size sizes) modules'
moduleFile | isSigned = "src/signed/i" ++ show size ++ ".rs"
| otherwise = "src/unsigned/u" ++ show size ++ ".rs" | otherwise = "src/unsigned/u" ++ show size ++ ".rs"
allSource = SourceFile Nothing [] (baseInclude : moduleSources) allSource = SourceFile Nothing [] (baseInclude : map fst moduleSources)
in [Task moduleFile (\ hndl -> writeSourceFile hndl allSource)] in [Task moduleFile (\ hndl -> writeSourceFile hndl allSource)] ++ map snd moduleSources
generateSubmodule :: Word -> [Word] -> RustModule -> Item Span generateSubmodule :: Bool -> Word -> [Word] -> RustModule -> (Item Span, Task)
generateSubmodule size allSizes m = generateSubmodule isSigned size allSizes m =
let SourceFile _ attrs internals = generator m size allSizes let modBody = generator m size allSizes
modName = mkIdent (outputName m) modName = mkIdent (outputName m)
modSpan = spanOf internals modDecl = Mod [] CrateV modName Nothing (Span NoPosition NoPosition)
in Mod attrs CrateV modName (Just internals) modSpan modFile | isSigned = "src/signed/i" ++ show size ++ "/" ++ outputName m ++ ".rs"
| otherwise = "src/unsigned/u" ++ show size ++ "/" ++ outputName m ++ ".rs"
in (modDecl, Task modFile (\ hndl -> writeSourceFile hndl modBody))
generateTests :: RandomGen g => generateTests :: RandomGen g =>
Word -> g -> Word -> g ->