diff --git a/generation/src/Karatsuba.hs b/generation/src/Karatsuba.hs index c7a173a..bbabda5 100644 --- a/generation/src/Karatsuba.hs +++ b/generation/src/Karatsuba.hs @@ -23,6 +23,7 @@ import qualified Data.Map.Strict as Map import Data.Vector(Vector, (!?)) import qualified Data.Vector as V import Data.Word +import Debug.Trace import Prelude hiding (fail) import Test.QuickCheck hiding ((.&.)) @@ -31,13 +32,19 @@ inputWordSize :: Int inputWordSize = 5 generateInstructions :: Word -> [Instruction] -generateInstructions numdigits = 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)) +generateInstructions numdigits = + let (baseVec, baseInstrs) = runMath $ do x <- V.replicateM (fromIntegral numdigits) (genDigit 1) + y <- V.replicateM (fromIntegral numdigits) (genDigit 1) + karatsuba x y + in baseInstrs + +-- 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 -- is the destination and the rest are the arguments. -data Instruction = Add String [String] - | CastDown String String - | CastUp String String - | Complement String String - | Declare64 String Word64 - | Declare128 String Word128 - | Mask String String Word128 - | Multiply String [String] - | ShiftR String String Int +data Instruction = Add Variable [Variable] + | CastDown Variable Variable + | CastUp Variable Variable + | Complement Variable Variable + | Declare64 Variable Word64 + | Declare128 Variable Word128 + | Mask Variable Variable Word128 + | Multiply Variable [Variable] + | ShiftR Variable Variable Int deriving (Eq, Show) class Declarable a where - declare :: String -> a -> Instruction + declare :: Variable -> a -> Instruction instance Declarable Word64 where - declare n x = Declare64 n x + declare n x = Declare64 n x 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 (env64, env128) i = @@ -91,12 +101,11 @@ step (env64, env128) i = ShiftR outname item amt -> (env64, Map.insert outname (getv env128 item `shiftR` amt) env128) where + getv :: Map Variable a -> Variable -> a getv env s = case Map.lookup s env of - Nothing -> - error ("Failure to find key '" ++ s ++ "'") - Just v -> - v + Nothing -> error ("Failure to find key '" ++ show s ++ "'") + Just v -> v run :: Env -> [Instruction] -> Env run env instrs = @@ -104,7 +113,7 @@ run env instrs = [] -> env (x:rest) -> run (step env x) rest -replaceVar :: [Instruction] -> (String, String) -> [Instruction] +replaceVar :: [Instruction] -> (Variable, Variable) -> [Instruction] replaceVar ls (from, to) = map replace ls where replace x = @@ -138,10 +147,10 @@ instance MonadFail Math where emit :: Instruction -> Math () emit instr = tell [instr] -gensym :: String -> Math String -gensym base = +newVariable :: Math Variable +newVariable = do x <- state (\ i -> (i, i + 1)) - return (base ++ show x) + return (V (show x)) runMath :: Math a -> (a, [Instruction]) runMath m = evalRWS (unMath m) () 0 @@ -153,14 +162,14 @@ runMath m = evalRWS (unMath m) () 0 -- ----------------------------------------------------------------------------- data Digit size = D { - name :: String + name :: Variable , digit :: size } deriving (Eq,Show) -genDigit :: Declarable size => String -> size -> Math (Digit size) -genDigit nm x = - do newName <- gensym nm +genDigit :: Declarable size => size -> Math (Digit size) +genDigit x = + do newName <- newVariable emit (declare newName x) return D{ name = newName @@ -169,60 +178,60 @@ genDigit nm x = embiggen :: Digit Word64 -> Math (Digit Word128) embiggen x = - do newName <- gensym ("big_" ++ name x) + do newName <- newVariable emit (CastUp newName (name x)) return (D newName (fromIntegral (digit x))) bottomBits :: Digit Word128 -> Math (Digit Word64) bottomBits x = - do newName <- gensym ("norm_" ++ name x) + do newName <- newVariable emit (CastDown newName (name x)) return (D newName (fromIntegral (digit x))) oneDigit :: Math (Digit Word64) -oneDigit = genDigit "one" 1 +oneDigit = genDigit 1 bigZero :: Math (Digit Word128) -bigZero = genDigit "zero" 0 +bigZero = genDigit 0 (|+|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128) (|+|) x y = - do newName <- gensym "plus" + do newName <- newVariable emit (Add newName [name x, name y]) let digval = digit x + digit y return (D newName digval) sumDigits :: [Digit Word128] -> Math (Digit Word128) sumDigits ls = - do newName <- gensym "sum" + do newName <- newVariable emit (Add newName (map name ls)) let digval = sum (map digit ls) return (D newName digval) (|*|) :: Digit Word128 -> Digit Word128 -> Math (Digit Word128) (|*|) x y = - do newName <- gensym "times" + do newName <- newVariable emit (Multiply newName [name x, name y]) let digval = digit x * digit y return (D newName digval) (|>>|) :: Digit Word128 -> Int -> Math (Digit Word128) (|>>|) x s = - do newName <- gensym "shiftr" + do newName <- newVariable emit (ShiftR newName (name x) s) let digval = digit x `shiftR` s return (D newName digval) (|&|) :: Digit Word128 -> Word128 -> Math (Digit Word128) (|&|) x m = - do newName <- gensym ("masked_" ++ name x) + do newName <- newVariable emit (Mask newName (name x) m) let digval = digit x .&. m return (D newName digval) complementDigit :: Digit Word64 -> Math (Digit Word64) complementDigit x = - do newName <- gensym ("comp_" ++ name x) + do newName <- newVariable emit (Complement newName (name x)) return (D newName (complement (digit x))) @@ -234,44 +243,31 @@ complementDigit x = type Number = Vector (Digit Word64) -instance Arbitrary Number where - arbitrary = - do ls <- replicateM inputWordSize (D "" <$> arbitrary) - return (V.fromList ls) - -rename :: String -> Number -> Number -rename var num = go 0 num +convertTo :: Int -> Integer -> Math Number +convertTo sz num = V.fromList `fmap` go sz num where - go :: Word -> Number -> Number - go i v = - case v !? 0 of - Nothing -> V.empty - Just x -> D (var ++ show i) (digit x) `V.cons` go (i + 1) (V.drop 1 v) - -convertTo :: Int -> Integer -> Number -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}) + go :: Int -> Integer -> Math [Digit Word64] + go 0 _ = + return [] + go x v = + do d <- genDigit (fromIntegral v) + rest <- go (x - 1) (v `shiftR` 64) + return (d:rest) convertFrom :: Number -> Integer convertFrom n = V.foldr combine 0 n where 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 n = - n' == convertFrom (convertTo inputWordSize n) - where n' = n `mod` (2 ^ (inputWordSize * 64)) +prop_ConversionWorksInt n = n' == back + where + n' = abs n `mod` (2 ^ (inputWordSize * 64)) + there = fst (runMath (convertTo inputWordSize n')) + back = convertFrom there 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 = null @@ -282,33 +278,50 @@ size = length splitDigits :: Int -> Number -> Math (Number, Number) splitDigits i ls = return (V.splitAt i ls) -prop_SplitDigitsIsntTerrible :: Int -> Number -> Bool -prop_SplitDigitsIsntTerrible x n = - let ((left, right), _) = runMath (splitDigits x' n) - in n == (left <> right) - where x' = x `mod` inputWordSize +prop_SplitDigitsIsntTerrible :: Int -> Int -> Integer -> Bool +prop_SplitDigitsIsntTerrible a b n = + let a' = a `mod` 20 + b' = b `mod` 20 + (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 x n = do prefix <- zero x return (prefix <> n) -prop_AddZerosIsShift :: Int -> Number -> Bool +prop_AddZerosIsShift :: Int -> Integer -> Bool prop_AddZerosIsShift x n = - let x' = abs (x `mod` inputWordSize) - nInt = convertFrom n - shiftVersion = nInt `shiftL` (x' * 64) - addVersion = convertFrom (fst (runMath (addZeros x' n))) - in shiftVersion == addVersion - + fst $ runMath $ do base <- convertTo inputWordSize n' + added <- addZeros x' base + let shiftVer = n' `shiftL` (x' * 64) + let mine = convertFrom added + return (shiftVer == mine) + where + x' = abs x `mod` inputWordSize + n' = abs n `mod` (2 ^ (inputWordSize * 64)) + padTo :: Int -> Number -> Math Number padTo len num = do suffix <- zero (len - V.length num) return (num <> suffix) -prop_PadToWorks :: Int -> Number -> Property -prop_PadToWorks len num = len >= size num ==> - convertFrom num == convertFrom (fst (runMath (padTo len num))) +prop_PadToWorks :: Int -> Int -> Integer -> Bool +prop_PadToWorks a b 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 xs ys @@ -330,14 +343,18 @@ add2 xs ys let res' = res <> V.singleton newdigit return (res', carry') -prop_Add2Works :: Number -> Number -> Bool -prop_Add2Works n m = - let nInt = convertFrom n - mInt = convertFrom m - intRes = nInt + mInt - (numRes, _) = runMath (add2 n m) - numResInt = convertFrom numRes - in (size numRes == inputWordSize + 1) && (intRes == numResInt) +prop_Add2Works :: Int -> Integer -> Integer -> Bool +prop_Add2Works l n m = + fst $ runMath $ do num1 <- convertTo l' n' + num2 <- convertTo l' m' + res <- add2 num1 num2 + let intRes = convertFrom res + return ((intRes == r) && (size res == l' + 1)) + 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 x y z @@ -362,15 +379,20 @@ add3 x y z let res' = res <> V.singleton digit' return (res', carry') -prop_Add3Works :: Number -> Number -> Number -> Bool -prop_Add3Works x y z = - let xInt = convertFrom x - yInt = convertFrom y - zInt = convertFrom z - intRes = xInt + yInt + zInt - (numRes, _) = runMath (add3 x y z) - numResInt = convertFrom numRes - in (size numRes == inputWordSize + 1) && (intRes == numResInt) +prop_Add3Works :: Int -> Integer -> Integer -> Integer -> Bool +prop_Add3Works l x y z = + fst $ runMath $ do num1 <- convertTo l' x' + num2 <- convertTo l' y' + num3 <- convertTo l' z' + res <- add3 num1 num2 num3 + let intRes = convertFrom res + return ((intRes == r) && (size res == l' + 1)) + 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 x y @@ -383,16 +405,20 @@ sub2 x y res <- add3 x yinv one return (V.take (size x) res) -prop_Sub2Works :: Number -> Number -> Bool -prop_Sub2Works a b - | convertFrom a < convertFrom b = prop_Sub2Works b a - | otherwise = - let aInt = convertFrom a - bInt = convertFrom b - intRes = aInt - bInt - (numRes, _) = runMath (sub2 a b) - numResInt = convertFrom numRes - in intRes == numResInt +prop_Sub2Works :: Int -> Integer -> Integer -> Bool +prop_Sub2Works l a b = + fst $ runMath $ do num1 <- convertTo l' x + num2 <- convertTo l' y + res <- sub2 num1 num2 + let intRes = convertFrom res + return (intRes == r) + where + l' = max 1 (abs l `mod` inputWordSize) + 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]) prop_MulNWorks :: Int -> (Number -> Number -> Math Number) -> - Number -> Number -> + Integer -> Integer -> Bool prop_MulNWorks nsize f x y = - let (x', _) = runMath (padTo nsize (V.take nsize x)) - (y', _) = runMath (padTo nsize (V.take nsize y)) - xInt = convertFrom x' - yInt = convertFrom y' - resInt = xInt * yInt - (resNum, _) = runMath (f x' y') - in (size x' == nsize) && (size y' == nsize) && - (size resNum == (nsize * 2)) && - (resInt == convertFrom resNum) + fst $ runMath $ do num1 <- convertTo nsize x' + num2 <- convertTo nsize y' + res <- f num1 num2 + let resInt = convertFrom res + return ((size res == (nsize * 2)) && (resInt == (x' * y'))) + + where + x' = abs x `mod` (2 ^ (64 * nsize)) + y' = abs y `mod` (2 ^ (64 * nsize)) -prop_Mul1Works :: Number -> Number -> Bool +prop_Mul1Works :: Integer -> Integer -> Bool prop_Mul1Works = prop_MulNWorks 1 mul1 mul2 :: Number -> Number -> Math Number @@ -456,7 +482,7 @@ mul2 num1 num2 dest3 <- bottomBits =<< (l1r1'' |>>| 64) return (V.fromList [dest0, dest1, dest2, dest3]) -prop_Mul2Works :: Number -> Number -> Bool +prop_Mul2Works :: Integer -> Integer -> Bool prop_Mul2Works = prop_MulNWorks 2 mul2 mul3 :: Number -> Number -> Math Number @@ -506,7 +532,7 @@ mul3 num1 num2 dest5 <- bottomBits =<< (l2r2' |>>| 64) 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 karatsuba :: Number -> Number -> Math Number @@ -544,43 +570,69 @@ karatsuba num1 num2 az0 <- padTo addsize z0 az1 <- padTo addsize z1' 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 x y = - let shouldBe = convertFrom x * convertFrom y - monad = karatsuba x y - myVersion = convertFrom (fst (runMath monad)) - in shouldBe == myVersion - -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) +prop_KaratsubaWorks :: Int -> Integer -> Integer -> Bool +prop_KaratsubaWorks l x y = + fst $ runMath $ do num1 <- convertTo l' x' + num2 <- convertTo l' y' + res <- karatsuba num1 num2 + let resInt = convertFrom res + sizeOk = size res == (l' * 2) + valOk = resInt == (x' * y') + return (sizeOk && valOk) + where - x' = rename "x" x - y' = rename "y" y - startEnv = (Map.fromList startEnv64, Map.empty) - startEnv64 = map (\ d -> (name d, digit d)) (V.toList (x' <> y')) + l' = (abs l `mod` (inputWordSize * 2)) + 2 + x' = abs x `mod` (2 ^ (64 * l')) + y' = abs y `mod` (2 ^ (64 * l')) + + +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 = case Map.lookup n env of - Nothing -> error ("InstrProp lookup failure: " ++ n) + Nothing -> error ("InstrProp lookup failure: " ++ show n) Just v -> D n v -prop_InstructionsConsistent :: Number -> Number -> Number -> Number -> Bool -prop_InstructionsConsistent a b x y = - let (_, instrs1) = runMath (karatsuba a' b') - (_, instrs2) = runMath (karatsuba x' y') - in instrs1 == instrs2 +prop_InstructionsConsistent :: Int -> Integer -> Integer -> Integer -> Integer -> Bool +prop_InstructionsConsistent l a b x y = + let (_, instrs1) = runMath (karatsuba' a' b') + (_, instrs2) = runMath (karatsuba' x' y') + instrs1' = dropWhile isDeclare64 instrs1 + instrs2' = dropWhile isDeclare64 instrs2 + in instrs1' == instrs2' where - a' = rename "p" a - b' = rename "q" b - x' = rename "p" x - y' = rename "q" y + l' = max 1 (abs l `mod` inputWordSize) + a' = abs a `mod` (2 ^ (64 * l')) + b' = abs b `mod` (2 ^ (64 * l')) + 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 = - do runQuickCheck "Num -> Int -> Num " prop_ConversionWorksNum - runQuickCheck "Int -> Num -> Int " prop_ConversionWorksInt + do runQuickCheck "Int -> Num -> Int " prop_ConversionWorksInt runQuickCheck "Split Isn't Dumb " prop_SplitDigitsIsntTerrible runQuickCheck "More 0s is Shift " prop_AddZerosIsShift runQuickCheck "PadTo Does That " prop_PadToWorks diff --git a/generation/src/Multiply.hs b/generation/src/Multiply.hs index b1f9354..a1cdf88 100644 --- a/generation/src/Multiply.hs +++ b/generation/src/Multiply.hs @@ -205,90 +205,91 @@ generateMultiplier fullmul size inName outName = in [stmt| $$vec.value[$$(liti)] = $$var; |] translateInstruction :: Instruction -> Stmt Span -translateInstruction instr = - case instr of - Add outname args -> - let outid = mkIdent outname - args' = map (\x -> [expr| $$x |]) (map mkIdent args) - adds = foldl (\ x y -> [expr| $$(x) + $$(y) |]) - (head args') - (tail args') - in [stmt| let $$outid: u128 = $$(adds); |] - CastDown outname arg -> - let outid = mkIdent outname - inid = mkIdent arg - in [stmt| let $$outid: u64 = $$inid as u64; |] - CastUp outname arg -> - let outid = mkIdent outname - inid = mkIdent arg - in [stmt| let $$outid: u128 = $$inid as u128; |] - Complement outname arg -> - let outid = mkIdent outname - inid = mkIdent arg - in [stmt| let $$outid: u64 = !$$inid; |] - Declare64 outname arg -> - let outid = mkIdent outname - val = toLit (fromIntegral arg) - in [stmt| let $$outid: u64 = $$(val); |] - Declare128 outname arg -> - let outid = mkIdent outname - val = toLit (fromIntegral arg) - in [stmt| let $$outid: u128 = $$(val); |] - Mask outname arg mask -> - let outid = mkIdent outname - inid = mkIdent arg - val = toLit (fromIntegral mask) - in [stmt| let $$outid: u128 = $$inid & $$(val); |] - Multiply outname args -> - let outid = mkIdent outname - args' = map (\x -> [expr| $$x |]) (map mkIdent args) - muls = foldl (\ x y -> [expr| $$(x) * $$(y) |]) - (head args') - (tail args') - in [stmt| let $$outid: u128 = $$(muls); |] - ShiftR outname arg amt -> - let outid = mkIdent outname - inid = mkIdent arg - val = toLit (fromIntegral amt) - in [stmt| let $$outid: u128 = $$inid >> $$(val); |] +translateInstruction instr = undefined +-- case instr of +-- Add outname args -> +-- let outid = mkIdent outname +-- args' = map (\x -> [expr| $$x |]) (map mkIdent args) +-- adds = foldl (\ x y -> [expr| $$(x) + $$(y) |]) +-- (head args') +-- (tail args') +-- in [stmt| let $$outid: u128 = $$(adds); |] +-- CastDown outname arg -> +-- let outid = mkIdent outname +-- inid = mkIdent arg +-- in [stmt| let $$outid: u64 = $$inid as u64; |] +-- CastUp outname arg -> +-- let outid = mkIdent outname +-- inid = mkIdent arg +-- in [stmt| let $$outid: u128 = $$inid as u128; |] +-- Complement outname arg -> +-- let outid = mkIdent outname +-- inid = mkIdent arg +-- in [stmt| let $$outid: u64 = !$$inid; |] +-- Declare64 outname arg -> +-- let outid = mkIdent outname +-- val = toLit (fromIntegral arg) +-- in [stmt| let $$outid: u64 = $$(val); |] +-- Declare128 outname arg -> +-- let outid = mkIdent outname +-- val = toLit (fromIntegral arg) +-- in [stmt| let $$outid: u128 = $$(val); |] +-- Mask outname arg mask -> +-- let outid = mkIdent outname +-- inid = mkIdent arg +-- val = toLit (fromIntegral mask) +-- in [stmt| let $$outid: u128 = $$inid & $$(val); |] +-- Multiply outname args -> +-- let outid = mkIdent outname +-- args' = map (\x -> [expr| $$x |]) (map mkIdent args) +-- muls = foldl (\ x y -> [expr| $$(x) * $$(y) |]) +-- (head args') +-- (tail args') +-- in [stmt| let $$outid: u128 = $$(muls); |] +-- ShiftR outname arg amt -> +-- let outid = mkIdent outname +-- inid = mkIdent arg +-- val = toLit (fromIntegral amt) +-- in [stmt| let $$outid: u128 = $$inid >> $$(val); |] releaseUnnecessary :: [String] -> [Instruction] -> [Instruction] -releaseUnnecessary outkeys instrs = go (Set.fromList outkeys) [] rInstrs - 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 - -outVar :: Instruction -> String -outVar instr = - case instr of - Add outname _ -> outname - CastDown outname _ -> outname - CastUp outname _ -> outname - Complement outname _ -> outname - Declare64 outname _ -> outname - Declare128 outname _ -> outname - Mask outname _ _ -> outname - Multiply outname _ -> outname - ShiftR outname _ _ -> outname - -inVars :: Instruction -> [String] -inVars instr = - case instr of - Add _ args -> args - CastDown _ arg -> [arg] - CastUp _ arg -> [arg] - Complement _ arg -> [arg] - Declare64 _ _ -> [] - Declare128 _ _ -> [] - Mask _ arg _ -> [arg] - Multiply _ args -> args - ShiftR _ arg _ -> [arg] +releaseUnnecessary outkeys instrs = undefined +-- go (Set.fromList outkeys) [] rInstrs +-- 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 +-- +--outVar :: Instruction -> String +--outVar instr = +-- case instr of +-- Add outname _ -> outname +-- CastDown outname _ -> outname +-- CastUp outname _ -> outname +-- Complement outname _ -> outname +-- Declare64 outname _ -> outname +-- Declare128 outname _ -> outname +-- Mask outname _ _ -> outname +-- Multiply outname _ -> outname +-- ShiftR outname _ _ -> outname +-- +--inVars :: Instruction -> [String] +--inVars instr = +-- case instr of +-- Add _ args -> args +-- CastDown _ arg -> [arg] +-- CastUp _ arg -> [arg] +-- Complement _ arg -> [arg] +-- Declare64 _ _ -> [] +-- Declare128 _ _ -> [] +-- Mask _ arg _ -> [arg] +-- Multiply _ args -> args +-- ShiftR _ arg _ -> [arg] -- -----------------------------------------------------------------------------