diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 1.0.12 +version: 1.0.13 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -75,9 +75,10 @@ mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (parseAlpha "/dev/stdin" str) putStrLn "\rGoodbye !" compileProgram (language,entryName) = withInitialContext $ do - importLanguage (const $ return ()) language - entrySym <- viewState language_ $ internSym entryName - tagIO ("Linking program "++entryName) $ do + langTime <- importLanguage (const $ return ()) language + progTime <- modTime entryName + when (progTime < langTime) $ tagIO ("Linking program "++entryName) $ do + entrySym <- viewState language_ $ internSym entryName _ <- getAddressComp (outputArch ?settings) entrySym (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses top <- gets compTop diff --git a/src/Serialize.hs b/src/Serialize.hs --- a/src/Serialize.hs +++ b/src/Serialize.hs @@ -13,33 +13,32 @@ import My.Control.Monad import PCode -deriving instance Generic Code -deriving instance Generic BindVar deriving instance Generic Builtin deriving instance Generic C.Value deriving instance Generic Axiom deriving instance Generic (Range a) - +instance Serialize Builtin +instance Serialize C.Value +instance Serialize Axiom instance Serialize a => Serialize (Range a) -instance (Ord a,Ord b,Serialize a,Serialize b) => Serialize (BM.Bimap a b) where - get = BM.fromList $< get - put = put . BM.toList -newtype Squashed = Squash { unSquash :: Int } +newtype SquashedI = SqI { unSqI :: Int } +newtype SquashedL a = SqL { unSqL :: [a] } +newtype SquashedM a = SqM { unSqM :: BM.Bimap String a } -instance Serialize Squashed where - put (Squash n) = do - let bytes = map fromIntegral $ takeWhile (>0) $ iterate (`shiftR`8) n - putWord8 (fromIntegral $ length bytes) - mapM_ putWord8 bytes - get = do - n <- getWord8 +instance Serialize SquashedI where + put (SqI n) = putWord8 (fromIntegral $ length bytes) >> mapM_ putWord8 bytes + where bytes = map fromIntegral $ takeWhile (>0) $ iterate (`shiftR`8) n + get = getWord8 >>= \n -> do bytes <- mapM (const getWord8) [1..n] - return $ Squash $ sum (zipWith shiftL (map fromIntegral bytes) [0,8..]) + return $ SqI $ sum (zipWith shiftL (map fromIntegral bytes) [0,8..]) +instance Serialize a => Serialize (SquashedL a) where + put (SqL l) = put (SqI $ length l) >> mapM_ put l + get = get >>= \(SqI n) -> SqL $< mapM (const get) [1..n] +instance (Ord a,Serialize a) => Serialize (SquashedM a) where + put (SqM m) = put $ SqL [(SqL n,v) | (n,v) <- BM.toList m] + get = get >§ \(SqL l) -> SqM (BM.fromList [(n,v) | (SqL n,v) <- l]) -instance Serialize Builtin -instance Serialize C.Value -instance Serialize Axiom typeCodes = [(Value,0),(GValue,1),(Address,2),(Size,3),(SymID,4)] instance Serialize PCode.Value where put (SymVal t n) = putWord8 (fromJust (lookup t typeCodes)) >> put n @@ -52,45 +51,45 @@ 6 -> return NullVal instance Serialize Code where put (Code [] [Branch _ []] Nothing) = putWord8 0 - put (Code [] instrs ret) = putWord8 1 >> put (instrs,ret) - put (Code args instrs ret) = putWord8 2 >> put (args,instrs,ret) + put (Code [] instrs ret) = putWord8 1 >> put (SqL instrs,ret) + put (Code args instrs ret) = putWord8 2 >> put (SqL args,SqL instrs,ret) get = getWord8 >>= \n -> case n of 0 -> return $ Code [] [Branch NullVal []] Nothing - 1 -> get >§ \(instrs,ret) -> Code [] instrs ret - 2 -> get >§ \(args,instrs,ret) -> Code args instrs ret + 1 -> get >§ \(SqL instrs,ret) -> Code [] instrs ret + 2 -> get >§ \(SqL args,SqL instrs,ret) -> Code args instrs ret instance Serialize Instruction where put (Op b d [x]) = putWord8 0 >> put (b,d,x) put (Op b d [x,y]) = putWord8 1 >> put (b,d,x,y) - put (Op b d l) = putWord8 2 >> put (b,d,l) + put (Op b d l) = putWord8 2 >> put (b,d,SqL l) put (Branch _ []) = putWord8 3 put (Branch _ [x]) = putWord8 4 >> put x put (Branch v [x,y]) = putWord8 5 >> put (v,x,y) - put (Branch v l) = putWord8 6 >> put (v,l) + put (Branch v l) = putWord8 6 >> put (v,SqL (map SqI l)) put (Bind bv x) = putWord8 7 >> put (bv,x) put Noop = putWord8 8 get = getWord8 >>= \x -> case x of 0 -> get >§ \(b,d,x) -> Op b d [x] 1 -> get >§ \(b,d,x,y) -> Op b d [x,y] - 2 -> get >§ \(b,d,l) -> Op b d l + 2 -> get >§ \(b,d,SqL l) -> Op b d l 3 -> return $ Branch NullVal [] 4 -> get >§ \x -> Branch NullVal [x] 5 -> get >§ \(v,x,y) -> Branch v [x,y] - 6 -> get >§ \(v,l) -> Branch v l + 6 -> get >§ \(v,SqL l) -> Branch v (map unSqI l) 7 -> get >§ \(bv,x) -> Bind bv x 8 -> return Noop instance Serialize BindVar where put (BindVar sym (0,1) 0 []) = putWord8 0 >> put sym - put (BindVar sym (n,nr) pad []) = putWord8 1 >> put (sym,Squash n,Squash nr,Squash pad) - put (BindVar sym (n,nr) pad subs) = putWord8 2 >> put (sym,Squash n,Squash nr,Squash pad,subs) + put (BindVar sym (n,nr) pad []) = putWord8 1 >> put (sym,SqI n,SqI nr,SqI pad) + put (BindVar sym (n,nr) pad subs) = putWord8 2 >> put (sym,SqI n,SqI nr,SqI pad,SqL subs) get = getWord8 >>= \n -> case n of 0 -> get >§ \sym -> BindVar sym (0,1) 0 [] - 1 -> get >§ \(sym,Squash n,Squash nr,Squash pad) -> BindVar sym (n,nr) pad [] - 2 -> get >§ \(sym,Squash n,Squash nr,Squash pad,subs) -> BindVar sym (n,nr) pad subs + 1 -> get >§ \(sym,SqI n,SqI nr,SqI pad) -> BindVar sym (n,nr) pad [] + 2 -> get >§ \(sym,SqI n,SqI nr,SqI pad,SqL subs) -> BindVar sym (n,nr) pad subs instance Serialize ID where - put (ID n) = put (Squash n) - get = ID . unSquash $< get - + put (ID n) = put (SqI n) + get = ID . unSqI $< get + instance Serialize Language where - put l = put (maxIDL l,symbolsL l,valuesL l,languagesL l) - get = get >§ \(mi,syms,vals,langs) -> mempty{ maxIDL = mi, symbolsL = syms, valuesL = vals, languagesL = langs } + put l = put (maxIDL l,SqM (symbolsL l),valuesL l,SqM (languagesL l)) + get = get >§ \(mi,SqM syms,vals,SqM langs) -> mempty{ maxIDL = mi, symbolsL = syms, valuesL = vals, languagesL = langs } diff --git a/src/Specialize/X86_64/Binary.hs b/src/Specialize/X86_64/Binary.hs --- a/src/Specialize/X86_64/Binary.hs +++ b/src/Specialize/X86_64/Binary.hs @@ -119,7 +119,7 @@ withSpecial spe f d r (Left n) = fromMaybe (f d r (Left n)) $ spe d r n withSpecial _ f d r v = f d r v -ignoreZero = const $ const $ flip lookup [(0,return ())] +ignoreZero _ _ = flip lookup [(0,return ())] shli = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,4))]) undefined shri = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,5))]) undefined @@ -164,7 +164,13 @@ (addrr,addri',addir) = commOp [0x03] [(8,(0x83,1,0)),(32,(0x81,4,0))] mulri = withSpecial spe mulri' where spe d r n = liftM (shli d r . Left . fi) $ log2n n -(mulrr,mulri',mulir) = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))] +mulir = flip . mulri +mulrr = op [0x0F,0xAF] +mulri' d a i = case codeFun [(8,(0x6B,1,undefined)),(32,(0x69,4,undefined))] i of + Just (code,_,sz,imm) -> tell (fromBytesN (length pref+sz) (liftM (pref++) imm)) + where (pre,suf) = argBytes d a Nothing + pref = pre++[code]++suf + Nothing -> movi rsi i >> mulrr d a rsi (bwandrr,bwandri,bwandir) = commOp [0x23] [(7,(0x83,1,4)),(31,(0x81,4,4))] (bworrr,bworri,bworir) = commOp [0x0b] [(7,(0x83,1,1)),(31,(0x81,4,1))] (bwxorrr,bwxorri,bwxorir) = commOp [0x33] [(7,(0x83,1,6)),(31,(0x81,4,6))]